Merge branch 'master' of git://factorcode.org/git/factor into llvm
Matthew Willis
commit
2f80903224
|
|
@ -3,15 +3,13 @@
|
|||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBFramework Version</key>
|
||||
<string>629</string>
|
||||
<string>677</string>
|
||||
<key>IBOldestOS</key>
|
||||
<integer>5</integer>
|
||||
<key>IBOpenObjects</key>
|
||||
<array>
|
||||
<integer>305</integer>
|
||||
</array>
|
||||
<array/>
|
||||
<key>IBSystem Version</key>
|
||||
<string>9G55</string>
|
||||
<string>9J61</string>
|
||||
<key>targetFramework</key>
|
||||
<string>IBCocoaFramework</string>
|
||||
</dict>
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -1,17 +1,32 @@
|
|||
{
|
||||
IBClasses = (
|
||||
{
|
||||
ACTIONS = {
|
||||
newFactorWorkspace = id;
|
||||
runFactorFile = id;
|
||||
saveFactorImage = id;
|
||||
saveFactorImageAs = id;
|
||||
showFactorHelp = id;
|
||||
};
|
||||
CLASS = FirstResponder;
|
||||
LANGUAGE = ObjC;
|
||||
SUPERCLASS = NSObject;
|
||||
}
|
||||
);
|
||||
IBVersion = 1;
|
||||
}
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBClasses</key>
|
||||
<array>
|
||||
<dict>
|
||||
<key>ACTIONS</key>
|
||||
<dict>
|
||||
<key>newFactorWorkspace</key>
|
||||
<string>id</string>
|
||||
<key>runFactorFile</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImage</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImageAs</key>
|
||||
<string>id</string>
|
||||
<key>showFactorHelp</key>
|
||||
<string>id</string>
|
||||
</dict>
|
||||
<key>CLASS</key>
|
||||
<string>FirstResponder</string>
|
||||
<key>LANGUAGE</key>
|
||||
<string>ObjC</string>
|
||||
<key>SUPERCLASS</key>
|
||||
<string>NSObject</string>
|
||||
</dict>
|
||||
</array>
|
||||
<key>IBVersion</key>
|
||||
<string>1</string>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
|
|||
|
|
@ -1,21 +1,18 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBDocumentLocation</key>
|
||||
<string>1266 155 525 491 0 0 2560 1578 </string>
|
||||
<key>IBEditorPositions</key>
|
||||
<dict>
|
||||
<key>29</key>
|
||||
<string>326 905 270 44 0 0 2560 1578 </string>
|
||||
</dict>
|
||||
<key>IBFramework Version</key>
|
||||
<string>439.0</string>
|
||||
<string>677</string>
|
||||
<key>IBOldestOS</key>
|
||||
<integer>5</integer>
|
||||
<key>IBOpenObjects</key>
|
||||
<array>
|
||||
<integer>29</integer>
|
||||
<integer>293</integer>
|
||||
</array>
|
||||
<key>IBSystem Version</key>
|
||||
<string>8R218</string>
|
||||
<string>9J61</string>
|
||||
<key>targetFramework</key>
|
||||
<string>IBCocoaFramework</string>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -31,7 +31,8 @@ ERROR: cairo-error message ;
|
|||
<cairo> &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
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@ USING: help.markup help.syntax ;
|
|||
IN: cocoa.windows
|
||||
|
||||
HELP: <NSWindow>
|
||||
{ $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: <ViewWindow>
|
||||
{ $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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
[ <basic-block> swap >>number swap >>instructions ] keep set ;
|
||||
|
|
@ -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
|
||||
{ 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
|
||||
|
|
@ -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' )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -140,4 +140,5 @@ PRIVATE>
|
|||
|
||||
: make-bitmap-image ( dim quot -- image )
|
||||
'[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
|
||||
ARGB >>component-order ; inline
|
||||
ARGB >>component-order
|
||||
ubyte-components >>component-type ; inline
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ) image new ; inline
|
||||
|
||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||
|
||||
GENERIC: load-image* ( path class -- image )
|
||||
|
||||
DEFER: bytes-per-pixel
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bytes-per-component ( component-type -- n )
|
||||
{
|
||||
{ ubyte-components [ 1 ] }
|
||||
{ ushort-components [ 2 ] }
|
||||
{ half-components [ 2 ] }
|
||||
{ float-components [ 4 ] }
|
||||
{ byte-integer-components [ 1 ] }
|
||||
{ ubyte-integer-components [ 1 ] }
|
||||
{ short-integer-components [ 2 ] }
|
||||
{ ushort-integer-components [ 2 ] }
|
||||
{ int-integer-components [ 4 ] }
|
||||
{ uint-integer-components [ 4 ] }
|
||||
} case ;
|
||||
|
||||
: component-count ( component-order -- n )
|
||||
{
|
||||
{ L [ 1 ] }
|
||||
{ LA [ 2 ] }
|
||||
|
|
@ -22,25 +68,11 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
|
|||
{ XRGB [ 4 ] }
|
||||
{ BGRX [ 4 ] }
|
||||
{ XBGR [ 4 ] }
|
||||
{ R16G16B16 [ 6 ] }
|
||||
{ R32G32B32 [ 12 ] }
|
||||
{ R16G16B16A16 [ 8 ] }
|
||||
{ R32G32B32A32 [ 16 ] }
|
||||
} case ;
|
||||
|
||||
TUPLE: image dim component-order upside-down? bitmap ;
|
||||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||
|
||||
GENERIC: load-image* ( path class -- image )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: pixel@ ( x y image -- start end bitmap )
|
||||
[ dim>> 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <array> >>bitmap
|
||||
drop ;
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@ ERROR: unimplemented-color-type image ;
|
|||
[ <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 )
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ IN: images.processing
|
|||
<image> 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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-image> ( 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 <tile-image> ] map ] map ;
|
||||
[ [ image <tile-image> ] map ] map ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[ <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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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 <CGRect> ;
|
||||
|
||||
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" }
|
||||
|
|
|
|||
|
|
@ -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." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: element { type integer } name ;
|
||||
TUPLE: state
|
||||
{ size initial: -1 } { read initial: 0 } exemplar
|
||||
{ size initial: -1 } exemplar
|
||||
result scope element ;
|
||||
|
||||
: <state> ( 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 <decoder>
|
||||
"\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 )
|
||||
<state> dup state
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
[ result>> ] [ read>> ] bi ;
|
||||
result>> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: shared-buffer
|
||||
|
||||
CONSTANT: CHAR-SIZE 1
|
||||
CONSTANT: INT32-SIZE 4
|
||||
CONSTANT: CHAR-SIZE 1
|
||||
CONSTANT: INT64-SIZE 8
|
||||
|
||||
: (buffer) ( -- buffer )
|
||||
shared-buffer get
|
||||
[ 8192 <byte-vector> [ 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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: bson-type? ( obj -- type ) foldable flushable
|
||||
GENERIC: bson-write ( obj -- )
|
||||
GENERIC: bson-type? ( obj -- type )
|
||||
GENERIC: bson-write ( obj -- )
|
||||
|
||||
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
|
||||
M: real bson-type? ( real -- type ) drop T_Double ;
|
||||
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
|
||||
M: sequence bson-type? ( seq -- type ) drop T_Array ;
|
||||
M: string bson-type? ( string -- type ) drop T_String ;
|
||||
M: integer bson-type? ( integer -- type ) drop T_Integer ;
|
||||
M: assoc bson-type? ( assoc -- type ) drop T_Object ;
|
||||
M: real bson-type? ( real -- type ) drop T_Double ;
|
||||
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
|
||||
M: sequence bson-type? ( seq -- type ) drop T_Array ;
|
||||
M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
|
||||
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
|
||||
|
||||
|
|
@ -76,28 +73,27 @@ M: word bson-type? ( word -- type ) drop T_Binary ;
|
|||
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
|
||||
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
|
||||
|
||||
: write-utf8-string ( string -- )
|
||||
output-stream get utf8 <encoder> 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|| ;
|
||||
[ oid? ] [ byte-array? ] } 1|| ; inline
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -11,30 +12,31 @@ IN: images.normalization
|
|||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <groups> [ 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 <sliced-groups> [ <reversed> ] map B{ } join ; inline
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Sascha Matzke
|
||||
|
|
@ -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 <inet> 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 <threaded-server> [ mmm-t-srv set ] keep
|
||||
"127.0.0.1" mmm-port get <inet4> >>insecure
|
||||
[ handle-mmm-connection ] >>handler
|
||||
start-server* ;
|
||||
|
||||
: run-mmm ( -- )
|
||||
check-options
|
||||
start-mmm-server ;
|
||||
|
||||
MAIN: run-mmm
|
||||
|
|
@ -1 +0,0 @@
|
|||
mongo-message-monitor - a small proxy to introspect messages send to MongoDB
|
||||
|
|
@ -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
|
||||
[ <mdb-reply-msg> ] 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ TUPLE: segment image ;
|
|||
<image>
|
||||
swap >>bitmap
|
||||
RGBA >>component-order
|
||||
ubyte-components >>component-type
|
||||
terrain-segment-size >>dim ;
|
||||
|
||||
: terrain-segment ( terrain at -- image )
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue