From 93fcc8358cb59ab0c36445e06a76c1e0e75c0f63 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 1 Jun 2009 22:37:44 -0500 Subject: [PATCH 01/27] Words in images to get and set pixels --- basis/images/authors.txt | 3 ++- basis/images/images-tests.factor | 29 +++++++++++++++++++++++++++++ basis/images/images.factor | 22 ++++++++++++++++++++-- 3 files changed, 51 insertions(+), 3 deletions(-) create mode 100644 basis/images/images-tests.factor diff --git a/basis/images/authors.txt b/basis/images/authors.txt index b4bd0e7b35..a4a77d97e9 100644 --- a/basis/images/authors.txt +++ b/basis/images/authors.txt @@ -1 +1,2 @@ -Doug Coleman \ No newline at end of file +Doug Coleman +Daniel Ehrenberg diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor new file mode 100644 index 0000000000..39e8b4a364 --- /dev/null +++ b/basis/images/images-tests.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: images tools.test kernel accessors ; +IN: images.tests + +[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 57 57 57 255 + 0 0 0 0 +} } pixel-at ] unit-test + +[ B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 57 57 57 255 + 0 0 0 0 +} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 +} } [ set-pixel-at ] keep bitmap>> ] unit-test diff --git a/basis/images/images.factor b/basis/images/images.factor index 178b91ab52..ed317b4685 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel accessors ; +USING: combinators kernel accessors sequences math ; IN: images SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR @@ -35,3 +35,21 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; GENERIC: load-image* ( path tuple -- image ) + +> second * + ] + [ component-order>> bytes-per-pixel [ * dup ] keep + ] + [ bitmap>> ] tri ; + +: set-subseq ( new-value from to victim -- ) + 0 swap copy ; inline + +PRIVATE> + +: pixel-at ( x y image -- pixel ) + pixel@ subseq ; + +: set-pixel-at ( pixel x y image -- ) + pixel@ set-subseq ; From 764cc81abf5a644a7ffd7cae22d719c4e079bfc9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 1 Jun 2009 22:39:02 -0500 Subject: [PATCH 02/27] unbits word in math.bits vocab --- basis/math/bits/bits-docs.factor | 6 +++++- basis/math/bits/bits-tests.factor | 3 +++ basis/math/bits/bits.factor | 3 +++ 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor index 6ae83f7af0..36043a5576 100644 --- a/basis/math/bits/bits-docs.factor +++ b/basis/math/bits/bits-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup math ; +USING: help.syntax help.markup math sequences ; IN: math.bits ABOUT: "math.bits" @@ -24,3 +24,7 @@ HELP: make-bits { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" } { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" } } ; + +HELP: unbits +{ $values { "seq" sequence } { "number" integer } } +{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ; diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor index b17d9d8b6e..c6f4c6e8fa 100644 --- a/basis/math/bits/bits-tests.factor +++ b/basis/math/bits/bits-tests.factor @@ -29,3 +29,6 @@ IN: math.bits.tests [ t ] [ 1067811677921310779 >bignum make-bits last ] unit-test + +[ 6 ] [ 6 make-bits unbits ] unit-test +[ 6 ] [ 6 3 >array unbits ] unit-test diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 72b83a991f..0fbfdf0bd9 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -14,3 +14,6 @@ M: bits length length>> ; M: bits nth-unsafe number>> swap bit? ; INSTANCE: bits immutable-sequence + +: unbits ( seq -- number ) + 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ; From 7aca07640886bdf234013e53a5337a46ce3d02df Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 2 Jun 2009 18:23:47 -0500 Subject: [PATCH 03/27] GC checks now save and restore registers --- .../build-stack-frame.factor | 74 ++++++++++ .../summary.txt | 0 basis/compiler/cfg/builder/builder.factor | 1 + basis/compiler/cfg/def-use/def-use.factor | 2 +- basis/compiler/cfg/gc-checks/gc-checks.factor | 7 +- .../cfg/instructions/instructions.factor | 12 +- .../linear-scan/assignment/assignment.factor | 34 ++++- .../cfg/linearization/linearization.factor | 55 +++++++- basis/compiler/cfg/mr/mr.factor | 2 +- basis/compiler/cfg/stack-frame/authors.txt | 1 + .../cfg/stack-frame/stack-frame.factor | 107 +++++++-------- basis/compiler/codegen/codegen.factor | 19 ++- basis/cpu/architecture/architecture.factor | 18 ++- basis/cpu/x86/64/64.factor | 4 +- basis/cpu/x86/x86.factor | 127 ++++++++++-------- basis/heaps/heaps.factor | 3 + vm/data_gc.cpp | 8 +- vm/data_gc.hpp | 2 +- 18 files changed, 319 insertions(+), 157 deletions(-) create mode 100644 basis/compiler/cfg/build-stack-frame/build-stack-frame.factor rename basis/compiler/cfg/{stack-frame => build-stack-frame}/summary.txt (100%) create mode 100644 basis/compiler/cfg/stack-frame/authors.txt diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor new file mode 100644 index 0000000000..e5be2d9eb9 --- /dev/null +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces accessors math.order assocs kernel sequences +combinators make classes words cpu.architecture +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.stack-frame ; +IN: compiler.cfg.build-stack-frame + +SYMBOL: frame-required? + +SYMBOL: spill-counts + +GENERIC: compute-stack-frame* ( insn -- ) + +: request-stack-frame ( stack-frame -- ) + stack-frame [ max-stack-frame ] change ; + +M: ##stack-frame compute-stack-frame* + frame-required? on + stack-frame>> request-stack-frame ; + +M: ##call compute-stack-frame* + word>> sub-primitive>> [ frame-required? on ] unless ; + +M: _gc compute-stack-frame* + frame-required? on + stack-frame new swap gc-root-size>> >>gc-root-size + request-stack-frame ; + +M: _spill-counts compute-stack-frame* + counts>> stack-frame get (>>spill-counts) ; + +M: insn compute-stack-frame* + class frame-required? word-prop [ + frame-required? on + ] when ; + +\ _spill t frame-required? set-word-prop +\ ##fixnum-add t frame-required? set-word-prop +\ ##fixnum-sub t frame-required? set-word-prop +\ ##fixnum-mul t frame-required? set-word-prop +\ ##fixnum-add-tail f frame-required? set-word-prop +\ ##fixnum-sub-tail f frame-required? set-word-prop +\ ##fixnum-mul-tail f frame-required? set-word-prop + +: compute-stack-frame ( insns -- ) + frame-required? off + T{ stack-frame } clone stack-frame set + [ compute-stack-frame* ] each + stack-frame get dup stack-frame-size >>total-size drop ; + +GENERIC: insert-pro/epilogues* ( insn -- ) + +M: ##stack-frame insert-pro/epilogues* drop ; + +M: ##prologue insert-pro/epilogues* + drop frame-required? get [ stack-frame get _prologue ] when ; + +M: ##epilogue insert-pro/epilogues* + drop frame-required? get [ stack-frame get _epilogue ] when ; + +M: insn insert-pro/epilogues* , ; + +: insert-pro/epilogues ( insns -- insns ) + [ [ insert-pro/epilogues* ] each ] { } make ; + +: build-stack-frame ( mr -- mr ) + [ + [ + [ compute-stack-frame ] + [ insert-pro/epilogues ] + bi + ] change-instructions + ] with-scope ; diff --git a/basis/compiler/cfg/stack-frame/summary.txt b/basis/compiler/cfg/build-stack-frame/summary.txt similarity index 100% rename from basis/compiler/cfg/stack-frame/summary.txt rename to basis/compiler/cfg/build-stack-frame/summary.txt diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 38075c24a3..d323263fc7 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -15,6 +15,7 @@ compiler.cfg.iterator compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics +compiler.cfg.stack-frame compiler.cfg.instructions compiler.alien ; IN: compiler.cfg.builder diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 1484b3ec72..cdd767ef8d 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -31,6 +31,7 @@ M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-float temp-vregs temp>> 1array ; M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; +M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: _dispatch temp-vregs temp>> 1array ; M: insn temp-vregs drop f ; @@ -51,7 +52,6 @@ M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##phi uses-vregs inputs>> ; -M: ##gc uses-vregs live-in>> ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 91e79ea2dd..4176914126 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences assocs cpu.architecture compiler.cfg.rpo -compiler.cfg.liveness compiler.cfg.instructions ; +compiler.cfg.liveness compiler.cfg.instructions +compiler.cfg.hats ; IN: compiler.cfg.gc-checks : gc? ( bb -- ? ) @@ -13,9 +14,7 @@ IN: compiler.cfg.gc-checks : insert-gc-check ( basic-block -- ) dup gc? [ - dup - [ swap object-pointer-regs \ ##gc new-insn prefix ] - change-instructions drop + [ i i f f \ ##gc new-insn prefix ] change-instructions drop ] [ drop ] if ; : insert-gc-checks ( cfg -- cfg' ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 314a66ba9c..fe853cf490 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -52,12 +52,6 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -TUPLE: stack-frame -{ params integer } -{ return integer } -{ total-size integer } -spill-counts ; - INSN: ##stack-frame stack-frame ; INSN: ##call word { height integer } ; INSN: ##jump word ; @@ -223,7 +217,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; -INSN: ##gc live-in ; +INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; @@ -243,6 +237,10 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; INSN: _compare-float-branch < _conditional-branch ; +TUPLE: spill-slot n ; C: spill-slot + +INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; + ! These instructions operate on machine registers and not ! virtual registers INSN: _spill src class n ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index c7e3380f83..0de350c215 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -58,17 +58,34 @@ SYMBOL: unhandled-intervals ] [ 2drop ] if ] if ; -GENERIC: assign-registers-in-insn ( insn -- ) +GENERIC: assign-before ( insn -- ) + +GENERIC: assign-after ( insn -- ) : all-vregs ( insn -- vregs ) [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; -M: vreg-insn assign-registers-in-insn +M: vreg-insn assign-before active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc >>regs drop ; -M: insn assign-registers-in-insn drop ; +M: insn assign-before drop ; + +: compute-live-registers ( -- regs ) + active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ; + +: compute-live-spill-slots ( -- spill-slots ) + unhandled-intervals get + heap-values [ reload-from>> ] filter + [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ; + +M: ##gc assign-after + compute-live-registers >>live-registers + compute-live-spill-slots >>live-spill-slots + drop ; + +M: insn assign-after drop ; : ( -- obj ) V{ } clone active-intervals boa ; @@ -82,10 +99,13 @@ M: insn assign-registers-in-insn drop ; [ [ [ - [ insn#>> activate-new-intervals ] - [ [ assign-registers-in-insn ] [ , ] bi ] - [ insn#>> expire-old-intervals ] - tri + { + [ insn#>> activate-new-intervals ] + [ assign-before ] + [ , ] + [ insn#>> expire-old-intervals ] + [ assign-after ] + } cleave ] each ] V{ } make ] change-instructions drop ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 53ca56907d..9e222f1832 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math accessors sequences namespaces make -combinators assocs -cpu.architecture +combinators assocs arrays locals cpu.architecture compiler.cfg compiler.cfg.rpo compiler.cfg.liveness +compiler.cfg.stack-frame compiler.cfg.instructions ; IN: compiler.cfg.linearization @@ -68,6 +68,57 @@ M: ##dispatch linearize-insn [ successors>> [ number>> _dispatch-label ] each ] bi* ; +: gc-root-registers ( n live-registers -- n ) + [ + [ second 2array , ] + [ first reg-class>> reg-size + ] + 2bi + ] each ; + +: gc-root-spill-slots ( n live-spill-slots -- n ) + [ + dup first reg-class>> int-regs eq? [ + [ second 2array , ] + [ first reg-class>> reg-size + ] + 2bi + ] [ drop ] if + ] each ; + +: oop-registers ( regs -- regs' ) + [ first reg-class>> int-regs eq? ] filter ; + +: data-registers ( regs -- regs' ) + [ first reg-class>> double-float-regs eq? ] filter ; + +:: compute-gc-roots ( live-registers live-spill-slots -- alist ) + [ + 0 + ! we put float registers last; the GC doesn't actually scan them + live-registers oop-registers gc-root-registers + live-spill-slots gc-root-spill-slots + live-registers data-registers gc-root-registers + drop + ] { } make ; + +: count-gc-roots ( live-registers live-spill-slots -- n ) + ! Size of GC root area, minus the float registers + [ oop-registers length ] bi@ + ; + +M: ##gc linearize-insn + nip + [ + [ temp1>> ] + [ temp2>> ] + [ + [ live-registers>> ] [ live-spill-slots>> ] bi + [ compute-gc-roots ] + [ count-gc-roots ] + [ gc-roots-size ] + 2tri + ] tri + _gc + ] with-regs ; + : linearize-basic-blocks ( cfg -- insns ) [ [ [ linearize-basic-block ] each-basic-block ] diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor index 49f7c793e5..9f6a62090c 100644 --- a/basis/compiler/cfg/mr/mr.factor +++ b/basis/compiler/cfg/mr/mr.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: compiler.cfg.linearization compiler.cfg.two-operand compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.cfg.rpo ; +compiler.cfg.build-stack-frame compiler.cfg.rpo ; IN: compiler.cfg.mr : build-mr ( cfg -- mr ) diff --git a/basis/compiler/cfg/stack-frame/authors.txt b/basis/compiler/cfg/stack-frame/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/stack-frame/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index fd11260f97..5cb5762b78 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -1,72 +1,55 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces accessors math.order assocs kernel sequences -combinators make classes words cpu.architecture -compiler.cfg.instructions compiler.cfg.registers ; +USING: math math.order namespaces accessors kernel layouts combinators +combinators.smart assocs sequences cpu.architecture ; IN: compiler.cfg.stack-frame -SYMBOL: frame-required? +TUPLE: stack-frame +{ params integer } +{ return integer } +{ total-size integer } +{ gc-root-size integer } +spill-counts ; -SYMBOL: spill-counts +! Stack frame utilities +: param-base ( -- n ) + stack-frame get [ params>> ] [ return>> ] bi + ; -GENERIC: compute-stack-frame* ( insn -- ) +: spill-float-offset ( n -- offset ) + double-float-regs reg-size * ; + +: spill-integer-base ( -- n ) + stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size * + param-base + ; + +: spill-integer-offset ( n -- offset ) + cells spill-integer-base + ; + +: spill-area-size ( stack-frame -- n ) + spill-counts>> [ swap reg-size * ] { } assoc>map sum ; + +: gc-root-base ( -- n ) + stack-frame get spill-area-size + param-base + ; + +: gc-root-offset ( n -- n' ) gc-root-base + ; + +: gc-roots-size ( live-registers live-spill-slots -- n ) + [ keys [ reg-class>> reg-size ] sigma ] bi@ + ; + +: (stack-frame-size) ( stack-frame -- n ) + [ + { + [ spill-area-size ] + [ gc-root-size>> ] + [ params>> ] + [ return>> ] + } cleave + ] sum-outputs ; : max-stack-frame ( frame1 frame2 -- frame3 ) [ stack-frame new ] 2dip [ [ params>> ] bi@ max >>params ] [ [ return>> ] bi@ max >>return ] - 2bi ; - -M: ##stack-frame compute-stack-frame* - frame-required? on - stack-frame>> stack-frame [ max-stack-frame ] change ; - -M: ##call compute-stack-frame* - word>> sub-primitive>> [ frame-required? on ] unless ; - -M: _spill-counts compute-stack-frame* - counts>> stack-frame get (>>spill-counts) ; - -M: insn compute-stack-frame* - class frame-required? word-prop [ - frame-required? on - ] when ; - -\ _spill t frame-required? set-word-prop -\ ##gc t frame-required? set-word-prop -\ ##fixnum-add t frame-required? set-word-prop -\ ##fixnum-sub t frame-required? set-word-prop -\ ##fixnum-mul t frame-required? set-word-prop -\ ##fixnum-add-tail f frame-required? set-word-prop -\ ##fixnum-sub-tail f frame-required? set-word-prop -\ ##fixnum-mul-tail f frame-required? set-word-prop - -: compute-stack-frame ( insns -- ) - frame-required? off - T{ stack-frame } clone stack-frame set - [ compute-stack-frame* ] each - stack-frame get dup stack-frame-size >>total-size drop ; - -GENERIC: insert-pro/epilogues* ( insn -- ) - -M: ##stack-frame insert-pro/epilogues* drop ; - -M: ##prologue insert-pro/epilogues* - drop frame-required? get [ stack-frame get _prologue ] when ; - -M: ##epilogue insert-pro/epilogues* - drop frame-required? get [ stack-frame get _epilogue ] when ; - -M: insn insert-pro/epilogues* , ; - -: insert-pro/epilogues ( insns -- insns ) - [ [ insert-pro/epilogues* ] each ] { } make ; - -: build-stack-frame ( mr -- mr ) - [ - [ - [ compute-stack-frame ] - [ insert-pro/epilogues ] - bi - ] change-instructions - ] with-scope ; + [ [ gc-root-size>> ] bi@ max >>gc-root-size ] + 2tri ; \ No newline at end of file diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 3962902c62..7bdaace1db 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -10,6 +10,7 @@ compiler.errors compiler.alien compiler.cfg compiler.cfg.instructions +compiler.cfg.stack-frame compiler.cfg.registers compiler.cfg.builder compiler.codegen.fixup @@ -234,7 +235,13 @@ M: ##write-barrier generate-insn [ table>> register ] tri %write-barrier ; -M: ##gc generate-insn drop %gc ; +M: _gc generate-insn + { + [ temp1>> register ] + [ temp2>> register ] + [ gc-roots>> ] + [ gc-root-count>> ] + } cleave %gc ; M: ##loop-entry generate-insn drop %loop-entry ; @@ -243,16 +250,6 @@ M: ##alien-global generate-insn %alien-global ; ! ##alien-invoke -GENERIC: reg-size ( register-class -- n ) - -M: int-regs reg-size drop cell ; - -M: single-float-regs reg-size drop 4 ; - -M: double-float-regs reg-size drop 8 ; - -M: stack-params reg-size drop "void*" heap-size ; - GENERIC: reg-class-variable ( register-class -- symbol ) M: reg-class reg-class-variable ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index f7f91524c3..805ba4fd71 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -12,12 +12,22 @@ SINGLETON: double-float-regs UNION: float-regs single-float-regs double-float-regs ; UNION: reg-class int-regs float-regs ; -! Mapping from register class to machine registers -HOOK: machine-registers cpu ( -- assoc ) - ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params +GENERIC: reg-size ( register-class -- n ) + +M: int-regs reg-size drop cell ; + +M: single-float-regs reg-size drop 4 ; + +M: double-float-regs reg-size drop 8 ; + +M: stack-params reg-size drop cell ; + +! Mapping from register class to machine registers +HOOK: machine-registers cpu ( -- assoc ) + ! Return values of this class go here GENERIC: return-reg ( register-class -- reg ) @@ -119,7 +129,7 @@ HOOK: %alien-global cpu ( dst symbol library -- ) HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) -HOOK: %gc cpu ( -- ) +HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0b9b4e8ddf..3a7221c239 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs @@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder -compiler.cfg.intrinsics ; +compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.x86.64 M: x86.64 machine-registers diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 1a2c2e3ee1..375ea32940 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences words system layouts combinators math.order fry locals compiler.constants compiler.cfg.registers compiler.cfg.instructions compiler.cfg.intrinsics -compiler.codegen compiler.codegen.fixup ; +compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ; IN: cpu.x86 << enable-fixnum-log2 >> @@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; M: x86 two-operand? t ; +HOOK: stack-reg cpu ( -- reg ) + +HOOK: reserved-area-size cpu ( -- n ) + +: stack@ ( n -- op ) stack-reg swap [+] ; + +: param@ ( n -- op ) reserved-area-size + stack@ ; + +: spill-integer@ ( n -- op ) spill-integer-offset param@ ; + +: spill-float@ ( n -- op ) spill-float-offset param@ ; + +: gc-root@ ( n -- op ) gc-root-offset param@ ; + +: decr-stack-reg ( n -- ) + dup 0 = [ drop ] [ stack-reg swap SUB ] if ; + +: incr-stack-reg ( n -- ) + dup 0 = [ drop ] [ stack-reg swap ADD ] if ; + +: align-stack ( n -- n' ) + os macosx? cpu x86.64? or [ 16 align ] when ; + +M: x86 stack-frame-size ( stack-frame -- i ) + (stack-frame-size) 3 cells reserved-area-size + + align-stack ; + HOOK: temp-reg-1 cpu ( -- reg ) HOOK: temp-reg-2 cpu ( -- reg ) @@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ; M: x86 %inc-d ( n -- ) ds-reg (%inc) ; M: x86 %inc-r ( n -- ) rs-reg (%inc) ; -: align-stack ( n -- n' ) - os macosx? cpu x86.64? or [ 16 align ] when ; - -HOOK: reserved-area-size cpu ( -- n ) - -M: x86 stack-frame-size ( stack-frame -- i ) - [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] - [ params>> ] - [ return>> ] - tri + + - 3 cells + - reserved-area-size + - align-stack ; - M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; : xt-tail-pic-offset ( -- n ) @@ -492,29 +504,58 @@ M:: x86 %write-barrier ( src card# table -- ) table table [] MOV table card# [+] card-mark MOV ; -M: x86 %gc ( -- ) - "end" define-label - temp-reg-1 load-zone-ptr - temp-reg-2 temp-reg-1 cell [+] MOV - temp-reg-2 1024 ADD - temp-reg-1 temp-reg-1 3 cells [+] MOV - temp-reg-2 temp-reg-1 CMP - "end" get JLE +:: check-nursery ( temp1 temp2 -- ) + temp1 load-zone-ptr + temp2 temp1 cell [+] MOV + temp2 1024 ADD + temp1 temp1 3 cells [+] MOV + temp2 temp1 CMP ; + +GENERIC# save-gc-root 1 ( gc-root operand temp -- ) + +M:: spill-slot save-gc-root ( gc-root spill-slot temp -- ) + temp spill-slot n>> spill-integer@ MOV + gc-root gc-root@ temp MOV ; + +M:: word save-gc-root ( gc-root register temp -- ) + gc-root gc-root@ register MOV ; + +: save-gc-roots ( gc-roots temp -- ) + '[ _ save-gc-root ] assoc-each ; + +GENERIC# load-gc-root 1 ( gc-root operand temp -- ) + +M:: spill-slot load-gc-root ( gc-root spill-slot temp -- ) + temp gc-root gc-root@ MOV + spill-slot n>> spill-integer@ temp MOV ; + +M:: word load-gc-root ( gc-root register temp -- ) + register gc-root gc-root@ MOV ; + +: load-gc-roots ( gc-roots temp -- ) + '[ _ load-gc-root ] assoc-each ; + +:: call-gc ( gc-root-count -- ) + ! Pass pointer to start of GC roots as first parameter + param-reg-1 gc-root-base param@ LEA + ! Pass number of roots as second parameter + param-reg-2 gc-root-count MOV + ! Call GC %prepare-alien-invoke - "minor_gc" f %alien-invoke + "inline_gc" f %alien-invoke ; + +M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- ) + "end" define-label + temp1 temp2 check-nursery + "end" get JLE + gc-roots temp1 save-gc-roots + gc-root-count call-gc + gc-roots temp1 load-gc-roots "end" resolve-label ; M: x86 %alien-global [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; -HOOK: stack-reg cpu ( -- reg ) - -: decr-stack-reg ( n -- ) - dup 0 = [ drop ] [ stack-reg swap SUB ] if ; - -: incr-stack-reg ( n -- ) - dup 0 = [ drop ] [ stack-reg swap ADD ] if ; - M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; :: %boolean ( dst temp word -- ) @@ -568,28 +609,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) { cc/= [ JNE ] } } case ; -: stack@ ( n -- op ) stack-reg swap [+] ; - -: param@ ( n -- op ) reserved-area-size + stack@ ; - -: spill-integer-base ( stack-frame -- n ) - [ params>> ] [ return>> ] bi + reserved-area-size + ; - -: spill-integer@ ( n -- op ) - cells - stack-frame get spill-integer-base - + stack@ ; - -: spill-float-base ( stack-frame -- n ) - [ spill-integer-base ] - [ spill-counts>> int-regs swap at int-regs reg-size * ] - bi + ; - -: spill-float@ ( n -- op ) - double-float-regs reg-size * - stack-frame get spill-float-base - + stack@ ; - M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ; M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index f2ccaad1b4..becfb6826d 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key ) [ dup heap-pop swap 2array ] produce nip ; +: heap-values ( heap -- alist ) + data>> [ value>> ] { } map-as ; + : slurp-heap ( heap quot: ( elt -- ) -- ) over heap-empty? [ 2drop ] [ [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index bcf6387639..6631a046ac 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -680,9 +680,15 @@ PRIMITIVE(become) compile_all_words(); } -VM_C_API void minor_gc() +VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size) { + for(cell i = 0; i < gc_roots_size; i++) + gc_local_push((cell)&gc_roots_base[i]); + garbage_collection(data->nursery(),false,0); + + for(cell i = 0; i < gc_roots_size; i++) + gc_local_pop(); } } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 2d6a1ab897..334ad5a2bb 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged) #endif } -VM_C_API void minor_gc(); +VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size); } From a1ca9fd51d97743a4ac5b644c0ae121ea75ffe8e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 2 Jun 2009 20:39:51 -0500 Subject: [PATCH 04/27] Redoing images.loader to work with jpeg --- basis/images/bitmap/bitmap.factor | 4 +++- basis/images/images.factor | 11 +++++++++-- basis/images/jpeg/jpeg.factor | 4 +++- basis/images/loader/loader.factor | 24 ++++++++++++------------ basis/images/png/png.factor | 5 ++++- basis/images/tiff/tiff.factor | 5 ++++- basis/ui/images/images.factor | 4 ++-- 7 files changed, 37 insertions(+), 20 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 48095bb26b..04a4fae77e 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary locals ; +strings images endian summary locals images.loader ; IN: images.bitmap : assert-sequence= ( a b -- ) @@ -129,6 +129,8 @@ ERROR: unknown-component-order bitmap ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) swap load-bitmap-data loading-bitmap>bitmap-image ; +"bmp" bitmap-image register-image-class + PRIVATE> : bitmap>color-index ( bitmap -- byte-array ) diff --git a/basis/images/images.factor b/basis/images/images.factor index ed317b4685..62c4f7e2ed 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel accessors sequences math ; +USING: combinators kernel accessors sequences math arrays ; IN: images SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR @@ -36,10 +36,17 @@ TUPLE: image dim component-order upside-down? bitmap ; GENERIC: load-image* ( path tuple -- image ) +: make-image ( bitmap -- image ) + ! bitmap is a sequence of sequences of pixels which are RGBA + + over [ first length ] [ length ] bi 2array >>dim + RGBA >>component-order + swap concat concat B{ } like >>bitmap ; + > second * + ] + [ dim>> first * + ] [ component-order>> bytes-per-pixel [ * dup ] keep + ] [ bitmap>> ] tri ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 648923704a..9d44aa1187 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order math.ranges math.vectors memoize multiline namespaces -sequences sequences.deep ; +sequences sequences.deep images.loader ; IN: images.jpeg QUALIFIED-WITH: bitstreams bs @@ -302,3 +302,5 @@ PRIVATE> M: jpeg-image load-image* ( path jpeg-image -- bitmap ) drop load-jpeg ; + +{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index d86b275635..19f2fd12c8 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,22 +1,22 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.pathnames -images.png ; +accessors images io.pathnames namespaces assocs ; IN: images.loader ERROR: unknown-image-extension extension ; +lower { - { "bmp" [ bitmap-image ] } - { "tif" [ tiff-image ] } - { "tiff" [ tiff-image ] } - ! { "jpg" [ jpeg-image ] } - ! { "jpeg" [ jpeg-image ] } - { "png" [ png-image ] } - [ unknown-image-extension ] - } case ; + file-extension >lower types get ?at + [ unknown-image-extension ] unless ; +PRIVATE> + +: register-image-class ( extension class -- ) + swap types get set-at ; : load-image ( path -- image ) dup image-class new load-image* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index c5b84de221..d4b284142f 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -3,7 +3,8 @@ USING: accessors constructors images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.files io.files.info kernel sequences io.streams.limited fry combinators arrays math -checksums checksums.crc32 compression.inflate grouping byte-arrays ; +checksums checksums.crc32 compression.inflate grouping byte-arrays +images.loader ; IN: images.png TUPLE: png-image < image chunks @@ -115,3 +116,5 @@ ERROR: unimplemented-color-type image ; M: png-image load-image* drop load-png ; + +"png" png-image register-image-class diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 27dc25de73..c98f737b11 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,8 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float locals ; +strings math.vectors specialized-arrays.float locals +images.loader ; IN: images.tiff TUPLE: tiff-image < image ; @@ -561,3 +562,5 @@ ERROR: unknown-component-order ifd ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) drop load-tiff tiff>image ; + +{ "tif" "tiff" } [ tiff-image register-image-class ] each diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor index 2b1caa8ab9..519217a644 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces cache images images.loader accessors assocs kernel opengl opengl.gl opengl.textures ui.gadgets.worlds -memoize ; +memoize images.tiff ; IN: ui.images TUPLE: image-name path ; @@ -29,4 +29,4 @@ PRIVATE> rendered-image draw-scaled-texture ; : image-dim ( image-name -- dim ) - cached-image dim>> ; \ No newline at end of file + cached-image dim>> ; From 04f1898461ca85fa5d06648e543ab1c3c75065d6 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 2 Jun 2009 21:17:45 -0500 Subject: [PATCH 05/27] fixing images unit test --- basis/images/images-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor index 39e8b4a364..8918dcb38c 100644 --- a/basis/images/images-tests.factor +++ b/basis/images/images-tests.factor @@ -7,18 +7,18 @@ IN: images.tests 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 57 57 57 255 0 0 0 0 + 0 0 0 0 } } pixel-at ] unit-test [ B{ 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 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{ 0 0 0 0 0 0 0 0 From 5e2b0fe401ec904378a38bcb37f4e4aeea93a08a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Jun 2009 23:20:07 -0500 Subject: [PATCH 06/27] report unhandled compression modes --- basis/images/bitmap/bitmap.factor | 34 +++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 04a4fae77e..998cf54075 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -21,7 +21,8 @@ TUPLE: bitmap-image < image ; TUPLE: loading-bitmap size reserved offset header-length width height planes bit-count compression size-image -x-pels y-pels color-used color-important rgb-quads color-index ; +x-pels y-pels color-used color-important color-palette color-index +uncompressed-bytes ; ERROR: bitmap-magic magic ; @@ -31,7 +32,7 @@ M: bitmap-magic summary buffer ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-palette>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; ERROR: bmp-not-supported n ; @@ -39,7 +40,7 @@ ERROR: bmp-not-supported n ; : reverse-lines ( byte-array width -- byte-array ) concat ; inline -: raw-bitmap>seq ( loading-bitmap -- array ) +: bitmap>bytes ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } @@ -48,6 +49,21 @@ ERROR: bmp-not-supported n ; [ bmp-not-supported ] } case >byte-array ; +ERROR: unsupported-bitmap-compression compression ; + +: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) + dup compression>> { + { 0 [ ] } + { 1 [ "run-length encoding 8" unsupported-bitmap-compression ] } + { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } + { 3 [ "bitfields" unsupported-bitmap-compression ] } + { 4 [ "jpeg" unsupported-bitmap-compression ] } + { 5 [ "png" unsupported-bitmap-compression ] } + } case ; + +: loading-bitmap>bytes ( loading-bitmap -- byte-array ) + uncompress-bitmap bitmap>bytes ; + : parse-file-header ( loading-bitmap -- loading-bitmap ) 2 read "BM" assert-sequence= read4 >>size @@ -67,7 +83,7 @@ ERROR: bmp-not-supported n ; read4 >>color-used read4 >>color-important ; -: rgb-quads-length ( loading-bitmap -- n ) +: color-palette-length ( loading-bitmap -- n ) [ offset>> 14 - ] [ header-length>> ] bi - ; : color-index-length ( loading-bitmap -- n ) @@ -98,11 +114,11 @@ ERROR: bmp-not-supported n ; ] when ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) - dup rgb-quads-length read >>rgb-quads + dup color-palette-length read >>color-palette dup color-index-length read >>color-index fixup-color-index ; -: load-bitmap-data ( path -- loading-bitmap ) +: load-bitmap ( path -- loading-bitmap ) binary [ loading-bitmap new parse-file-header parse-bitmap-header parse-bitmap @@ -120,14 +136,14 @@ ERROR: unknown-component-order bitmap ; : loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) { - [ raw-bitmap>seq >>bitmap ] + [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ height>> 0 < [ t >>upside-down? ] when ] [ bitmap>component-order >>component-order ] } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap-data loading-bitmap>bitmap-image ; + swap load-bitmap loading-bitmap>bitmap-image ; "bmp" bitmap-image register-image-class @@ -185,7 +201,7 @@ PRIVATE> ! color-important [ drop 0 write4 ] - ! rgb-quads + ! color-palette [ [ bitmap>color-index ] [ dim>> first 3 * ] From a14ec0db2f7e8453bcfb8c074993c7cabefff400 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Jun 2009 23:29:04 -0500 Subject: [PATCH 07/27] support run-length encoding in bitmaps --- basis/compression/run-length/run-length.factor | 7 +++++++ basis/images/bitmap/bitmap.factor | 9 +++++---- 2 files changed, 12 insertions(+), 4 deletions(-) create mode 100644 basis/compression/run-length/run-length.factor diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor new file mode 100644 index 0000000000..d281b0718a --- /dev/null +++ b/basis/compression/run-length/run-length.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays grouping sequences ; +IN: compression.run-length + +: run-length-uncompress8 ( byte-array -- byte-array' ) + 2 group [ first2 ] map concat ; diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 998cf54075..8bf8d59944 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary io.files -kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary locals images.loader ; +combinators compression.run-length endian fry grouping images +images.loader io io.binary io.encodings.binary io.files kernel +locals macros math math.bitwise math.functions namespaces +sequences strings summary ; IN: images.bitmap : assert-sequence= ( a b -- ) @@ -54,7 +55,7 @@ ERROR: unsupported-bitmap-compression compression ; : uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) dup compression>> { { 0 [ ] } - { 1 [ "run-length encoding 8" unsupported-bitmap-compression ] } + { 1 [ [ run-length-uncompress8 ] change-color-index ] } { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } { 3 [ "bitfields" unsupported-bitmap-compression ] } { 4 [ "jpeg" unsupported-bitmap-compression ] } From 9096acea6fd8c8dba55b6a1403e6ab31d3a80ee0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Jun 2009 03:22:27 -0500 Subject: [PATCH 08/27] Linear scan: build live ranges --- basis/compiler/cfg/def-use/def-use.factor | 8 -- .../cfg/linear-scan/linear-scan-tests.factor | 21 +--- .../live-intervals/live-intervals.factor | 106 ++++++++++++++---- 3 files changed, 86 insertions(+), 49 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index cdd767ef8d..4ff9814e6d 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -8,14 +8,6 @@ GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) M: ##flushable defs-vregs dst>> 1array ; -M: ##unary/temp defs-vregs dst>> 1array ; -M: ##allot defs-vregs dst>> 1array ; -M: ##slot defs-vregs dst>> 1array ; -M: ##set-slot defs-vregs temp>> 1array ; -M: ##string-nth defs-vregs dst>> 1array ; -M: ##compare defs-vregs dst>> 1array ; -M: ##compare-imm defs-vregs dst>> 1array ; -M: ##compare-float defs-vregs dst>> 1array ; M: insn defs-vregs drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 030d8503e9..e0cbe3774f 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -242,11 +242,12 @@ SYMBOL: max-uses max-insns get [ 0 ] replicate taken set max-insns get [ dup ] H{ } map>assoc available set [ - live-interval new + \ live-interval new swap int-regs swap vreg boa >>vreg max-uses get random 2 max [ not-taken ] replicate natural-sort [ >>uses ] [ first >>start ] bi dup uses>> last >>end + dup [ start>> ] [ end>> ] bi 1vector >>ranges ] map ] with-scope ; @@ -271,24 +272,6 @@ USING: math.private compiler.cfg.debugger ; test-cfg first optimize-cfg linear-scan drop ] unit-test -[ f ] [ - T{ basic-block - { instructions - V{ - T{ ##allot - f - T{ vreg f int-regs 1 } - 40 - array - T{ vreg f int-regs 2 } - f - } - } - } - } clone [ [ clone ] map ] change-instructions - dup 1array (linear-scan) instructions>> first regs>> values all-equal? -] unit-test - [ 0 1 ] [ { T{ live-interval diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 55bcdc7470..78ac9428d8 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,26 +1,56 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs accessors sequences math fry +USING: namespaces kernel assocs accessors sequences math math.order fry compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.def-use ; +compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals +TUPLE: live-range from to ; + +C: live-range + TUPLE: live-interval vreg reg spill-to reload-from split-before split-after -start end uses +start end ranges uses copy-from ; -: add-use ( n live-interval -- ) - dup live-interval? [ "No def" throw ] unless - [ (>>end) ] [ uses>> push ] 2bi ; +ERROR: dead-value-error vreg ; -: ( start vreg -- live-interval ) - live-interval new +: shorten-range ( n live-interval -- ) + dup ranges>> empty? + [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ; + +: extend-range ( from to live-range -- ) + ranges>> last + [ max ] change-to + [ min ] change-from + drop ; + +: add-new-range ( from to live-interval -- ) + [ ] dip ranges>> push ; + +: extend-range? ( to live-interval -- ? ) + ranges>> [ drop f ] [ last from>> >= ] if-empty ; + +: add-range ( from to live-interval -- ) + 2dup extend-range? + [ extend-range ] [ add-new-range ] if ; + +: add-use ( n live-interval -- ) + uses>> push ; + +: ( vreg -- live-interval ) + \ live-interval new V{ } clone >>uses - swap >>vreg - over >>start - [ add-use ] keep ; + V{ } clone >>ranges + swap >>vreg ; + +: block-from ( -- n ) + basic-block get instructions>> first insn#>> ; + +: block-to ( -- n ) + basic-block get instructions>> last insn#>> ; M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ; @@ -31,23 +61,31 @@ M: live-interval clone ! Mapping from vreg to live-interval SYMBOL: live-intervals -: new-live-interval ( n vreg live-intervals -- ) - 2dup key? [ - at add-use - ] [ - [ [ ] keep ] dip set-at - ] if ; +: live-interval ( vreg live-intervals -- live-interval ) + [ ] cache ; GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; +: handle-output ( n vreg live-intervals -- ) + live-interval + [ add-use ] [ shorten-range ] 2bi ; + +: handle-input ( n vreg live-intervals -- ) + live-interval + [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ; + +: handle-temp ( n vreg live-intervals -- ) + live-interval + [ dupd add-range ] [ add-use ] 2bi ; + M: vreg-insn compute-live-intervals* dup insn#>> live-intervals get - [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ] - [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] - [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] + [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ] + [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] + [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ] 3tri ; : record-copy ( insn -- ) @@ -59,8 +97,32 @@ M: ##copy compute-live-intervals* M: ##copy-float compute-live-intervals* [ call-next-method ] [ record-copy ] bi ; +: handle-live-out ( bb -- ) + live-out keys block-from block-to live-intervals get '[ + [ _ _ ] dip _ live-interval add-range + ] each ; + +: compute-live-intervals-step ( bb -- ) + [ basic-block set ] + [ handle-live-out ] + [ instructions>> [ compute-live-intervals* ] each ] tri ; + +: compute-start/end ( live-interval -- ) + dup ranges>> [ first from>> ] [ last to>> ] bi + [ >>start ] [ >>end ] bi* drop ; + +: finish-live-intervals ( live-intervals -- ) + ! Since live intervals are computed in a backward order, we have + ! to reverse some sequences, and compute the start and end. + [ + [ ranges>> reverse-here ] + [ uses>> reverse-here ] + [ compute-start/end ] + tri + ] each ; + : compute-live-intervals ( rpo -- live-intervals ) H{ } clone [ live-intervals set - [ instructions>> [ compute-live-intervals* ] each ] each - ] keep values ; + [ compute-live-intervals-step ] each + ] keep values dup finish-live-intervals ; From fd710385e58e5018bf871285e368bc38d79b96ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Jun 2009 03:22:46 -0500 Subject: [PATCH 09/27] cpu.x86: fix small register intrinsics on x86-64 --- basis/compiler/tests/codegen.factor | 9 +++++- basis/cpu/x86/x86.factor | 45 +++++++++++++++++++++-------- 2 files changed, 41 insertions(+), 13 deletions(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index e0bc917f1c..47c6fa31e7 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors grouping make ; +combinators vectors grouping make alien.c-types ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -282,3 +282,10 @@ TUPLE: cucumber ; M: cucumber equal? "The cucumber has no equal" throw ; [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test + +[ 4294967295 B{ 255 255 255 255 } -1 ] +[ + -1 -1 + [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ] + compile-call +] unit-test \ No newline at end of file diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 375ea32940..ef353281e5 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -327,17 +327,29 @@ M:: x86 %box-alien ( dst src temp -- ) "end" resolve-label ] with-scope ; -: small-reg-4 ( reg -- reg' ) +: small-reg-8 ( reg -- reg' ) H{ - { EAX EAX } - { ECX ECX } - { EDX EDX } - { EBX EBX } - { ESP ESP } - { EBP EBP } - { ESI ESP } - { EDI EDI } + { EAX RAX } + { ECX RCX } + { EDX RDX } + { EBX RBX } + { ESP RSP } + { EBP RBP } + { ESI RSP } + { EDI RDI } + { RAX RAX } + { RCX RCX } + { RDX RDX } + { RBX RBX } + { RSP RSP } + { RBP RBP } + { RSI RSP } + { RDI RDI } + } at ; inline + +: small-reg-4 ( reg -- reg' ) + small-reg-8 H{ { RAX EAX } { RCX ECX } { RDX EDX } @@ -373,12 +385,21 @@ M:: x86 %box-alien ( dst src temp -- ) { 1 [ small-reg-1 ] } { 2 [ small-reg-2 ] } { 4 [ small-reg-4 ] } + { 8 [ small-reg-8 ] } } case ; -: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline +HOOK: small-regs cpu ( -- regs ) + +M: x86.32 small-regs { EAX ECX EDX EBX } ; +M: x86.64 small-regs { RAX RCX RDX RBX } ; + +HOOK: small-reg-native cpu ( reg -- reg' ) + +M: x86.32 small-reg-native small-reg-4 ; +M: x86.64 small-reg-native small-reg-8 ; : small-reg-that-isn't ( exclude -- reg' ) - small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ; + small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ; : with-save/restore ( reg quot -- ) [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline @@ -388,7 +409,7 @@ M:: x86 %box-alien ( dst src temp -- ) #! call the quot with that. Otherwise, we find a small #! register that is not in exclude, and call quot, saving #! and restoring the small register. - dst small-reg-4 small-regs memq? [ dst quot call ] [ + dst small-reg-native small-regs memq? [ dst quot call ] [ exclude small-reg-that-isn't [ quot call ] with-save/restore ] if ; inline From f0b132fa7f90e060ecfe0893db567f674b31390f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Jun 2009 03:23:55 -0500 Subject: [PATCH 10/27] Fix 32-bit bootstrap --- basis/cpu/x86/32/32.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index cf84b083fe..b591b254f8 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -3,10 +3,11 @@ USING: locals alien.c-types alien.syntax arrays kernel math namespaces sequences system layouts io vocabs.loader accessors init combinators command-line cpu.x86.assembler -cpu.x86 cpu.architecture compiler compiler.units +cpu.x86 cpu.architecture make compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.intrinsics make ; +compiler.cfg.builder compiler.cfg.intrinsics +compiler.cfg.stack-frame ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. From 5e8bdff3a0c2855fda692690c519df12e9adf801 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 3 Jun 2009 11:02:41 -0500 Subject: [PATCH 11/27] typo in opengl.gl --- basis/opengl/gl/gl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 39a8a2c4fe..be457dcd00 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ; GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ; -GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; +GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0 From d6f4c3ae44535ae99d451a6b6f1b748e1dfd9430 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 3 Jun 2009 11:03:34 -0500 Subject: [PATCH 12/27] null-world class for interactive OpenGL use --- basis/ui/gadgets/worlds/worlds.factor | 1 - basis/ui/ui.factor | 5 ++++- extra/ui/gadgets/worlds/null/null.factor | 27 ++++++++++++++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 extra/ui/gadgets/worlds/null/null.factor diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 38fb220c69..dfce3d3eee 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -217,4 +217,3 @@ M: world check-world-pixel-format : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline - diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 144530399c..aee19279a4 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -206,8 +206,11 @@ PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; +: open-window* ( gadget title/attributes -- window ) + ?attributes [ open-world-window ] keep ; + : open-window ( gadget title/attributes -- ) - ?attributes open-world-window ; + open-window* drop ; : set-fullscreen ( gadget ? -- ) [ find-world ] dip (set-fullscreen) ; diff --git a/extra/ui/gadgets/worlds/null/null.factor b/extra/ui/gadgets/worlds/null/null.factor new file mode 100644 index 0000000000..26fc3e8a94 --- /dev/null +++ b/extra/ui/gadgets/worlds/null/null.factor @@ -0,0 +1,27 @@ +USING: accessors kernel ui ui.backend ui.gadgets +ui.gadgets.worlds ui.pixel-formats ; +IN: ui.gadgets.worlds.null + +TUPLE: null-world < world ; +M: null-world begin-world drop ; +M: null-world end-world drop ; +M: null-world draw-world* drop ; +M: null-world resize-world drop ; +M: null-world pref-dim* drop { 512 512 } ; + +: null-window ( title -- world ) + + swap >>title + null-world >>world-class + { + windowed + double-buffered + backing-store + T{ depth-bits f 24 } + } >>pixel-format-attributes + f swap open-window* ; + +: into-window ( world quot -- world ) + [ dup handle>> ] dip with-gl-context ; inline + + From d940e1b91fbf81812040592debe24f73b14c7f75 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 3 Jun 2009 19:55:38 -0500 Subject: [PATCH 13/27] Catch and wrap game-loop errors and send them through the UI when available. much nicer than having to check the console --- extra/game-loop/game-loop.factor | 21 ++++++++++++++++--- .../game-loop/prettyprint/prettyprint.factor | 9 ++++++++ 2 files changed, 27 insertions(+), 3 deletions(-) create mode 100644 extra/game-loop/prettyprint/prettyprint.factor diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 8abbe6ba25..982319541b 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,5 +1,5 @@ -USING: accessors calendar destructors kernel math math.order namespaces -system threads ; +USING: accessors calendar continuations destructors kernel math +math.order namespaces system threads ui ui.gadgets.worlds ; IN: game-loop TUPLE: game-loop @@ -27,6 +27,16 @@ SYMBOL: game-loop CONSTANT: MAX-FRAMES-TO-SKIP 5 +DEFER: stop-loop + +TUPLE: game-loop-error game-loop error ; + +: ?ui-error ( error -- ) + ui-running? [ ui-error ] [ rethrow ] if ; + +: game-loop-error ( game-loop error -- ) + [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ; + > - ; @@ -91,3 +103,6 @@ PRIVATE> M: game-loop dispose stop-loop ; +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "game-loop.prettyprint" require ] when diff --git a/extra/game-loop/prettyprint/prettyprint.factor b/extra/game-loop/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..8b20dd4c9d --- /dev/null +++ b/extra/game-loop/prettyprint/prettyprint.factor @@ -0,0 +1,9 @@ +! (c)2009 Joe Groff bsd license +USING: accessors debugger game-loop io ; +IN: game-loop.prettyprint + +M: game-loop-error error. + "An error occurred inside a game loop." print + "The game loop has been stopped to prevent runaway errors." print + "The error was:" print nl + error>> error. ; From 9ba6f1205b18c5030d37344b3b9f78a54948e887 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 21:21:21 -0500 Subject: [PATCH 14/27] add a word to open a limited stream from a file correctly --- basis/images/png/png.factor | 3 +-- basis/io/streams/limited/limited.factor | 11 +++++++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index d4b284142f..b8a9a1d569 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -104,8 +104,7 @@ ERROR: unimplemented-color-type image ; } case ; : load-png ( path -- image ) - [ binary ] [ file-info size>> ] bi - stream-throws [ + binary stream-throws [ read-png-header read-png-chunks diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index b1b07a08c0..fd441e4c4d 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io io.encodings destructors accessors -sequences namespaces byte-vectors fry combinators ; +USING: accessors byte-vectors combinators destructors fry io +io.encodings io.files io.files.info kernel math namespaces +sequences ; IN: io.streams.limited TUPLE: limited-stream stream count limit mode stack ; @@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ; swap >>stream 0 >>count ; +: ( path encoding mode -- stream' ) + [ + [ ] + [ drop file-info size>> ] 2bi + ] dip ; + GENERIC# limit 2 ( stream limit mode -- stream' ) M: decoder limit ( stream limit mode -- stream' ) From f35bfb6dba1ed11d2d7c937a0ba0c5e0f5d5b385 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 21:21:51 -0500 Subject: [PATCH 15/27] add a word to make a sequence from a byte-array by taking n bits at a time --- basis/bitstreams/bitstreams.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index cb6a753735..4718f137e4 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ; writer bytes>> swap push ] unless writer bytes>> ; + +:: byte-array-n>seq ( byte-array n -- seq ) + byte-array length 8 * n / iota + byte-array '[ + drop n _ read + ] { } map-as ; From c0833e24de5cd0b27fae68aaaa97752c28a03f42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 21:22:19 -0500 Subject: [PATCH 16/27] rename run-length's uncompress word --- basis/compression/run-length/run-length.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index d281b0718a..6553860546 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -3,5 +3,5 @@ USING: arrays grouping sequences ; IN: compression.run-length -: run-length-uncompress8 ( byte-array -- byte-array' ) +: run-length-uncompress ( byte-array -- byte-array' ) 2 group [ first2 ] map concat ; From 488314ed1ae2f35d2c1baf1b0022e9c3571c7a6b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 21:36:03 -0500 Subject: [PATCH 17/27] clean up bitmap code, support a lot more bitmaps like 1/4/16 bit --- basis/images/bitmap/bitmap.factor | 228 ++++++++++++++++++++++-------- 1 file changed, 172 insertions(+), 56 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8bf8d59944..151c12132b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns combinators compression.run-length endian fry grouping images -images.loader io io.binary io.encodings.binary io.files kernel -locals macros math math.bitwise math.functions namespaces -sequences strings summary ; +images.loader io io.binary io.encodings.binary io.files +io.streams.limited kernel locals macros math math.bitwise +math.functions namespaces sequences specialized-arrays.uint +specialized-arrays.ushort strings summary io.encodings.8-bit +io.encodings.string ; +QUALIFIED-WITH: bitstreams b IN: images.bitmap -: assert-sequence= ( a b -- ) - 2dup sequence= [ 2drop ] [ assert ] if ; - : read2 ( -- n ) 2 read le> ; : read4 ( -- n ) 4 read le> ; : write2 ( n -- ) 2 >le write ; @@ -17,62 +17,130 @@ IN: images.bitmap TUPLE: bitmap-image < image ; -! Used to construct the final bitmap-image - TUPLE: loading-bitmap -size reserved offset header-length width +magic size reserved1 reserved2 offset header-length width height planes bit-count compression size-image -x-pels y-pels color-used color-important color-palette color-index -uncompressed-bytes ; +x-pels y-pels color-used color-important +red-mask green-mask blue-mask alpha-mask +cs-type end-points +gamma-red gamma-green gamma-blue +intent profile-data profile-size reserved3 +color-palette color-index bitfields ; -ERROR: bitmap-magic magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; +! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint buffer ( bitmap -- array ) - [ color-palette>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; +: os2-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: os2v2-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: v3-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 4 [ 3 head-slice ] map ] bi + '[ _ nth ] map concat ; + +: color-lookup ( loading-bitmap -- seq ) + dup header-length>> { + { 12 [ os2-color-lookup ] } + { 64 [ os2v2-color-lookup ] } + { 40 [ v3-color-lookup ] } + ! { 108 [ v4-color-lookup ] } + ! { 124 [ v5-color-lookup ] } + } case ; ERROR: bmp-not-supported n ; -: reverse-lines ( byte-array width -- byte-array ) - concat ; inline +: uncompress-bitfield ( seq masks -- bytes' ) + '[ + _ [ + [ bitand ] [ bit-count ] [ log2 ] tri - shift + ] with map + ] { } map-as B{ } concat-as ; -: bitmap>bytes ( loading-bitmap -- array ) +: bitmap>bytes ( loading-bitmap -- byte-array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } - { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } + { 24 [ color-index>> ] } + { 16 [ + [ + ! byte-array>ushort-array + 2 group [ le> ] map + ! 5 6 5 + ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield + ! 5 5 5 + { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield + ] change-color-index + color-index>> + ] } + { 8 [ color-lookup ] } + { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] } + { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] } [ bmp-not-supported ] } case >byte-array ; +: set-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + dup bit-count>> { + { 16 [ dup color-palette>> 4 group [ le> ] map ] } + { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] } + } case reverse >>bitfields ; + +ERROR: unsupported-bitfield-widths n ; + +M: unsupported-bitfield-widths summary + drop "Bitmaps only support bitfield compression in 16/32bit images" ; + +: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + set-bitfield-widths + dup bit-count>> { + { 16 [ + dup bitfields>> '[ + byte-array>ushort-array _ uncompress-bitfield + ] change-color-index + ] } + { 32 [ + dup bitfields>> '[ + byte-array>uint-array _ uncompress-bitfield + ] change-color-index + ] } + [ unsupported-bitfield-widths ] + } case ; + ERROR: unsupported-bitmap-compression compression ; : uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) dup compression>> { + { f [ ] } { 0 [ ] } - { 1 [ [ run-length-uncompress8 ] change-color-index ] } - { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } - { 3 [ "bitfields" unsupported-bitmap-compression ] } + { 1 [ [ run-length-uncompress ] change-color-index ] } + { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] } + { 3 [ uncompress-bitfield-widths ] } { 4 [ "jpeg" unsupported-bitmap-compression ] } { 5 [ "png" unsupported-bitmap-compression ] } } case ; +: bitmap-padding ( width -- n ) + 3 * 4 mod 4 swap - 4 mod ; inline + : loading-bitmap>bytes ( loading-bitmap -- byte-array ) - uncompress-bitmap bitmap>bytes ; + uncompress-bitmap + bitmap>bytes ; : parse-file-header ( loading-bitmap -- loading-bitmap ) - 2 read "BM" assert-sequence= + 2 read latin1 decode >>magic read4 >>size - read4 >>reserved + read2 >>reserved1 + read2 >>reserved2 read4 >>offset ; -: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) - read4 >>header-length +: read-v3-header ( loading-bitmap -- loading-bitmap ) read4 >>width read4 32 >signed >>height read2 >>planes @@ -84,6 +152,50 @@ ERROR: unsupported-bitmap-compression compression ; read4 >>color-used read4 >>color-important ; +: read-v4-header ( loading-bitmap -- loading-bitmap ) + read-v3-header + read4 >>red-mask + read4 >>green-mask + read4 >>blue-mask + read4 >>alpha-mask + read4 >>cs-type + read4 read4 read4 3array >>end-points + read4 >>gamma-red + read4 >>gamma-green + read4 >>gamma-blue ; + +: read-v5-header ( loading-bitmap -- loading-bitmap ) + read-v4-header + read4 >>intent + read4 >>profile-data + read4 >>profile-size + read4 >>reserved3 ; + +: read-os2-header ( loading-bitmap -- loading-bitmap ) + read2 >>width + read2 16 >signed >>height + read2 >>planes + read2 >>bit-count ; + +: read-os2v2-header ( loading-bitmap -- loading-bitmap ) + read4 >>width + read4 32 >signed >>height + read2 >>planes + read2 >>bit-count ; + +ERROR: unknown-bitmap-header n ; + +: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) + read4 [ >>header-length ] keep + { + { 12 [ read-os2-header ] } + { 64 [ read-os2v2-header ] } + { 40 [ read-v3-header ] } + { 108 [ read-v4-header ] } + { 124 [ read-v5-header ] } + [ unknown-bitmap-header ] + } case ; + : color-palette-length ( loading-bitmap -- n ) [ offset>> 14 - ] [ header-length>> ] bi - ; @@ -98,53 +210,54 @@ ERROR: unsupported-bitmap-compression compression ; : image-size ( loading-bitmap -- n ) [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; -: bitmap-padding ( width -- n ) - 3 * 4 mod 4 swap - 4 mod ; inline - -:: fixup-color-index ( loading-bitmap -- loading-bitmap ) - loading-bitmap width>> :> width - width 3 * :> width*3 - loading-bitmap width>> bitmap-padding :> padding - loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride - loading-bitmap - padding 0 > [ - [ - stride - [ width*3 head-slice ] map concat - ] change-color-index - ] when ; - : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup color-palette-length read >>color-palette - dup color-index-length read >>color-index - fixup-color-index ; + dup size-image>> [ + read >>color-index + ] [ + dup color-index-length read >>color-index + ] if* ; + +ERROR: unsupported-bitmap-file magic ; : load-bitmap ( path -- loading-bitmap ) - binary [ + binary stream-throws [ loading-bitmap new - parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader ; + parse-file-header dup magic>> { + { "BM" [ parse-bitmap-header parse-bitmap ] } + ! { "BA" [ parse-os2-bitmap-array ] } + ! { "CI" [ parse-os2-color-icon ] } + ! { "CP" [ parse-os2-color-pointer ] } + ! { "IC" [ parse-os2-icon ] } + ! { "PT" [ parse-os2-pointer ] } + [ unsupported-bitmap-file ] + } case + ] with-input-stream ; ERROR: unknown-component-order bitmap ; : bitmap>component-order ( loading-bitmap -- object ) bit-count>> { - { 32 [ BGRA ] } + { 32 [ BGR ] } { 24 [ BGR ] } + { 16 [ BGR ] } { 8 [ BGR ] } + { 4 [ BGR ] } + { 1 [ BGR ] } [ unknown-component-order ] } case ; -: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) +: loading-bitmap>image ( image loading-bitmap -- bitmap-image ) { [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] - [ height>> 0 < [ t >>upside-down? ] when ] + [ height>> 0 < not >>upside-down? ] + [ compression>> 3 = [ t >>upside-down? ] when ] [ bitmap>component-order >>component-order ] } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap loading-bitmap>bitmap-image ; + swap load-bitmap loading-bitmap>image ; "bmp" bitmap-image register-image-class @@ -165,6 +278,9 @@ PRIVATE> ] if ] bi ; +: reverse-lines ( byte-array width -- byte-array ) + concat ; inline + : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write From 37ceeca882b2400bb06229146932171e16ae825b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 22:19:46 -0500 Subject: [PATCH 18/27] really disconnect someone if name is taken --- extra/managed-server/chat/chat.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 4e841ec95e..f60445c48f 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect ] "" append-outputs-as send-everyone ; M: chat-server handle-already-logged-in - username username-taken-string send-line ; + username username-taken-string send-line + t client (>>quit?) ; M: chat-server handle-managed-client* readln dup f = [ t client (>>quit?) ] when From ed8181e5c3ab912ebad14532fdfaaf77ce7bdece Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Jun 2009 23:00:56 -0500 Subject: [PATCH 19/27] add a logged-in flag to managed-server for logging in connections so we don't have to throw exceptions to kill clients --- extra/managed-server/managed-server.factor | 31 +++++++++++++++------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d4a440525..6f9bdf25f1 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ; TUPLE: managed-client input-stream output-stream local-address remote-address -username object quit? ; +username object quit? logged-in? ; HOOK: handle-login threaded-server ( -- username ) HOOK: handle-managed-client* managed-server ( -- ) @@ -62,26 +62,39 @@ PRIVATE> local-address get >>local-address remote-address get >>remote-address ; -: check-logged-in ( username -- username ) - dup clients key? [ handle-already-logged-in ] when ; +: maybe-login-client ( -- ) + username clients key? [ + handle-already-logged-in + ] [ + t client (>>logged-in?) + client username clients set-at + ] if ; -: add-managed-client ( -- ) - client username check-logged-in clients set-at ; +: when-logged-in ( quot -- ) + client logged-in?>> [ call ] [ drop ] if ; inline : delete-managed-client ( -- ) - username server clients>> delete-at ; + [ username server clients>> delete-at ] when-logged-in ; : handle-managed-client ( -- ) handle-login managed-client set - add-managed-client handle-client-join - [ handle-managed-client* client quit?>> not ] loop ; + maybe-login-client [ + handle-client-join + [ handle-managed-client* client quit?>> not ] loop + ] when-logged-in ; + +: cleanup-client ( -- ) + [ + delete-managed-client + handle-client-disconnect + ] when-logged-in ; PRIVATE> M: managed-server handle-client* managed-server set [ handle-managed-client ] - [ delete-managed-client handle-client-disconnect ] + [ cleanup-client ] [ ] cleanup ; : new-managed-server ( port name encoding class -- server ) From c21076562e1c2ca2a68d2d569980190994c7ece4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 10:17:09 -0500 Subject: [PATCH 20/27] constructor foo now creates an initialize-foo word in the initializers vocabualary. is instantiated with boa constructors now, so constructors handle read-only slots --- basis/constructors/constructors-tests.factor | 30 ++++++++++- basis/constructors/constructors.factor | 52 +++++++++++++++----- 2 files changed, 69 insertions(+), 13 deletions(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index 367f0ad143..af1a879ee3 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test constructors calendar kernel accessors -combinators.short-circuit ; +combinators.short-circuit initializers math ; IN: constructors.tests TUPLE: stock-spread stock spread timestamp ; @@ -18,4 +18,30 @@ SYMBOL: AAPL [ spread>> 1234 = ] [ timestamp>> timestamp? ] } 1&& -] unit-test \ No newline at end of file +] unit-test + + +TUPLE: ct1 a ; +TUPLE: ct2 < ct1 b ; +TUPLE: ct3 < ct2 c ; +TUPLE: ct4 < ct3 d ; + +CONSTRUCTOR: ct1 ( a -- obj ) + [ 1 + ] change-a ; + +CONSTRUCTOR: ct2 ( a b -- obj ) + initialize-ct1 + [ 1 + ] change-a ; + +CONSTRUCTOR: ct3 ( a b c -- obj ) + initialize-ct1 + [ 1 + ] change-a ; + +CONSTRUCTOR: ct4 ( a b c d -- obj ) + initialize-ct3 + [ 1 + ] change-a ; + +[ 1 ] [ 0 a>> ] unit-test +[ 2 ] [ 0 0 a>> ] unit-test +[ 2 ] [ 0 0 0 a>> ] unit-test +[ 3 ] [ 0 0 0 0 a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 7a98cd5e0a..b08ac0cda3 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,23 +1,53 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: slots kernel sequences fry accessors parser lexer words -effects.parser macros ; +effects.parser macros generalizations locals classes.tuple +vocabs generic.standard ; IN: constructors ! An experiment -MACRO: set-slots ( slots -- quot ) - [ setter-word '[ swap _ execute ] ] map [ ] join ; +: initializer-name ( class -- word ) + name>> "initialize-" prepend ; -: construct ( ... class slots -- instance ) - [ new ] dip set-slots ; inline +: lookup-initializer ( class -- word/f ) + initializer-name "initializers" lookup ; -: define-constructor ( name class effect body -- ) - [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi - define-declared ; +: initializer-word ( class -- word ) + initializer-name + "initializers" create-vocab create + [ t "initializer" set-word-prop ] [ ] bi ; + +: define-initializer-generic ( name -- ) + initializer-word (( object -- object )) define-simple-generic ; + +: define-initializer ( class def -- ) + [ drop define-initializer-generic ] + [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; + +MACRO:: slots>constructor ( class slots -- quot ) + slots class + all-slots [ name>> ] map + [ '[ _ = ] find drop ] with map + [ [ ] count ] [ ] [ length ] tri + '[ + _ narray _ + [ swap over [ nth ] [ drop ] if ] with map + _ firstn class boa + ] ; + +:: define-constructor ( constructor-word class effect def -- ) + constructor-word + class def define-initializer + class effect in>> '[ _ _ slots>constructor ] + class lookup-initializer + '[ @ _ execute( obj -- obj ) ] effect define-declared ; + +: scan-constructor ( -- class word ) + scan-word [ name>> "<" ">" surround create-in ] keep ; SYNTAX: CONSTRUCTOR: - scan-word [ name>> "<" ">" surround create-in ] keep + scan-constructor complete-effect parse-definition - define-constructor ; \ No newline at end of file + define-constructor ; From a1f8ab1e6c3cdbd13254362bc860547c913d3d41 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 14:57:10 -0500 Subject: [PATCH 21/27] use initial values in constructors when approriate --- basis/constructors/constructors-tests.factor | 16 ++++++++++++++-- basis/constructors/constructors.factor | 19 +++++++++---------- 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index af1a879ee3..271e173718 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -20,7 +20,6 @@ SYMBOL: AAPL } 1&& ] unit-test - TUPLE: ct1 a ; TUPLE: ct2 < ct1 b ; TUPLE: ct3 < ct2 c ; @@ -41,7 +40,20 @@ CONSTRUCTOR: ct4 ( a b c d -- obj ) initialize-ct3 [ 1 + ] change-a ; -[ 1 ] [ 0 a>> ] unit-test +[ 1001 ] [ 1000 a>> ] unit-test [ 2 ] [ 0 0 a>> ] unit-test [ 2 ] [ 0 0 0 a>> ] unit-test [ 3 ] [ 0 0 0 0 a>> ] unit-test + + +TUPLE: rofl a b c ; +CONSTRUCTOR: rofl ( b c a -- obj ) ; + +[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 ] unit-test + + +TUPLE: default { a integer initial: 0 } ; + +CONSTRUCTOR: default ( -- obj ) ; + +[ 0 ] [ a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index b08ac0cda3..c2a7d828c9 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: slots kernel sequences fry accessors parser lexer words -effects.parser macros generalizations locals classes.tuple -vocabs generic.standard ; +USING: accessors assocs classes.tuple effects.parser fry +generalizations generic.standard kernel lexer locals macros +parser sequences slots vocabs words ; IN: constructors ! An experiment @@ -26,14 +26,13 @@ IN: constructors [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; MACRO:: slots>constructor ( class slots -- quot ) - slots class - all-slots [ name>> ] map - [ '[ _ = ] find drop ] with map - [ [ ] count ] [ ] [ length ] tri + class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params + slots length + params length '[ - _ narray _ - [ swap over [ nth ] [ drop ] if ] with map - _ firstn class boa + _ narray slots swap zip + params swap assoc-union + values _ firstn class boa ] ; :: define-constructor ( constructor-word class effect def -- ) From 8f4983aae45a6e2776f42919a80f44992efb51af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:06:33 -0500 Subject: [PATCH 22/27] fix loading of bitmaps when computed size is 0 --- basis/images/bitmap/bitmap.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 151c12132b..2ee7c2514c 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -212,11 +212,11 @@ ERROR: unknown-bitmap-header n ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup color-palette-length read >>color-palette - dup size-image>> [ + dup size-image>> dup 0 > [ read >>color-index ] [ - dup color-index-length read >>color-index - ] if* ; + drop dup color-index-length read >>color-index + ] if ; ERROR: unsupported-bitmap-file magic ; From 4235922ae5796aa34df6dbad8d2fc2d4363e6cc2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:09:25 -0500 Subject: [PATCH 23/27] don't normalize images in processing.rotation. this means there are some padding bytes to deal with --- extra/images/processing/rotation/rotation-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 493f09b145..9d9e72a205 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry images.loader images.normalization +USING: accessors fry images.loader images.processing.rotation kernel literals math sequences tools.test images.processing.rotation.private ; IN: images.processing.rotation.tests @@ -24,13 +24,13 @@ IN: images.processing.rotation.tests CONSTANT: pasted-image $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: pasted-image90 $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: lake-image @@ -55,7 +55,7 @@ CONSTANT: lake-image "vocab:images/processing/rotation/test-bitmaps/small.bmp" load-image 90 rotate "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" - load-image normalize-image = + load-image = ] unit-test [ t ] [ From dfd28cdcbbe188afe276e20bfce18c2b42f32653 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:30:17 -0500 Subject: [PATCH 24/27] create initializers vocab when constructors is used. this should really go in bootstrap instead --- basis/constructors/constructors.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index c2a7d828c9..e6982e3d98 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -50,3 +50,5 @@ SYNTAX: CONSTRUCTOR: complete-effect parse-definition define-constructor ; + +"initializers" create-vocab drop From 112e7c6898cb4c5931b084a6d0920a8fe8534a8e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 16:09:38 -0500 Subject: [PATCH 25/27] use singletons instead of subclassing the image class --- basis/images/bitmap/bitmap.factor | 12 +++++------- basis/images/images.factor | 9 +-------- basis/images/jpeg/jpeg.factor | 16 ++++++++-------- basis/images/loader/loader.factor | 4 +++- basis/images/png/png.factor | 13 +++++++------ basis/images/tiff/tiff.factor | 16 ++-------------- 6 files changed, 26 insertions(+), 44 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 2ee7c2514c..4f2ad720b6 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -15,7 +15,8 @@ IN: images.bitmap : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; -TUPLE: bitmap-image < image ; +SINGLETON: bitmap-image +"bmp" bitmap-image register-image-class TUPLE: loading-bitmap magic size reserved1 reserved2 offset header-length width @@ -247,7 +248,9 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: loading-bitmap>image ( image loading-bitmap -- bitmap-image ) +M: bitmap-image load-image* ( path bitmap-image -- bitmap ) + drop load-bitmap + [ image new ] dip { [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] @@ -256,11 +259,6 @@ ERROR: unknown-component-order bitmap ; [ bitmap>component-order >>component-order ] } cleave ; -M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap loading-bitmap>image ; - -"bmp" bitmap-image register-image-class - PRIVATE> : bitmap>color-index ( bitmap -- byte-array ) diff --git a/basis/images/images.factor b/basis/images/images.factor index 62c4f7e2ed..4c76b85459 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) - -: make-image ( bitmap -- image ) - ! bitmap is a sequence of sequences of pixels which are RGBA - - over [ first length ] [ length ] bi 2array >>dim - RGBA >>component-order - swap concat concat B{ } like >>bitmap ; +GENERIC: load-image* ( path class -- image ) ( -- jpeg-image ) jpeg-image get ; +: jpeg> ( -- jpeg-image ) loading-jpeg get ; : apply-diff ( dc color -- dc' ) [ diff>> + dup ] [ (>>diff) ] bi ; @@ -291,9 +293,9 @@ PRIVATE> binary [ parse-marker { SOI } assert= parse-headers - contents + contents ] with-file-reader - dup jpeg-image [ + dup loading-jpeg [ baseline-parse baseline-decompress jpeg> bitmap>> 3 [ color-transform ] change-each @@ -302,5 +304,3 @@ PRIVATE> M: jpeg-image load-image* ( path jpeg-image -- bitmap ) drop load-jpeg ; - -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 19f2fd12c8..51d4e0fadf 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -7,16 +7,18 @@ IN: images.loader ERROR: unknown-image-extension extension ; lower types get ?at [ unknown-image-extension ] unless ; + PRIVATE> : register-image-class ( extension class -- ) swap types get set-at ; : load-image ( path -- image ) - dup image-class new load-image* ; + dup image-class load-image* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b8a9a1d569..fd5e36e212 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays images.loader ; IN: images.png -TUPLE: png-image < image chunks +SINGLETON: png-image +"png" png-image register-image-class + +TUPLE: loading-png < image chunks width height bit-depth color-type compression-method filter-method interlace-method uncompressed ; -CONSTRUCTOR: png-image ( -- image ) -V{ } clone >>chunks ; +CONSTRUCTOR: loading-png ( -- image ) + V{ } clone >>chunks ; TUPLE: png-chunk length type data ; @@ -105,7 +108,7 @@ ERROR: unimplemented-color-type image ; : load-png ( path -- image ) binary stream-throws [ - + read-png-header read-png-chunks parse-ihdr-chunk @@ -115,5 +118,3 @@ ERROR: unimplemented-color-type image ; M: png-image load-image* drop load-png ; - -"png" png-image register-image-class diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c98f737b11..6b2de12d51 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -9,7 +9,7 @@ strings math.vectors specialized-arrays.float locals images.loader ; IN: images.tiff -TUPLE: tiff-image < image ; +SINGLETON: tiff-image TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; @@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case ; -: normalize-alpha-data ( seq -- byte-array ) - B{ } like dup - byte-array>float-array - 4 - [ - dup fourth dup 0 = [ - 2drop - ] [ - [ 3 head-slice ] dip '[ _ / ] change-each - ] if - ] each ; - : handle-alpha-data ( ifd -- ifd ) dup extra-samples find-tag { { extra-samples-associated-alpha-data [ ] } @@ -508,7 +496,7 @@ ERROR: unknown-component-order ifd ; [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order f ] [ bitmap>> ] - } cleave tiff-image boa ; + } cleave image boa ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; From 3e5f043da9277eec538748835b24405d3e1a9ec5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 16:17:26 -0500 Subject: [PATCH 26/27] renamd parsed-tiff to loading-tiff --- basis/images/tiff/tiff.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6b2de12d51..876076e9fe 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -11,8 +11,8 @@ IN: images.tiff SINGLETON: tiff-image -TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; -CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; +TUPLE: loading-tiff endianness the-answer ifd-offset ifds ; +CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips bitmap ; @@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ; [ nip unhandled-ifd-entry swap ] } case ; -: process-ifds ( parsed-tiff -- parsed-tiff ) +: process-ifds ( loading-tiff -- loading-tiff ) [ [ dup ifd-entries>> @@ -501,12 +501,12 @@ ERROR: unknown-component-order ifd ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; -: with-tiff-endianness ( parsed-tiff quot -- ) +: with-tiff-endianness ( loading-tiff quot -- ) [ dup endianness>> ] dip with-endianness ; inline -: load-tiff-ifds ( path -- parsed-tiff ) +: load-tiff-ifds ( path -- loading-tiff ) binary [ - + read-header [ dup ifd-offset>> read-ifds process-ifds @@ -538,10 +538,10 @@ ERROR: unknown-component-order ifd ; drop "no planar configuration" throw ] if ; -: process-tif-ifds ( parsed-tiff -- ) +: process-tif-ifds ( loading-tiff -- ) ifds>> [ process-ifd ] each ; -: load-tiff ( path -- parsed-tiff ) +: load-tiff ( path -- loading-tiff ) [ load-tiff-ifds dup ] keep binary [ [ process-tif-ifds ] with-tiff-endianness From ee67b7c9a89215ee42724151d0899e1b7a12d3a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Jun 2009 18:53:02 -0500 Subject: [PATCH 27/27] compiler.cfg.linear-scan: re-do interval splitting to operate on live ranges; add inactive set processing --- .../linear-scan/allocation/allocation.factor | 212 ++++++++++++++---- .../linear-scan/assignment/assignment.factor | 7 +- .../cfg/linear-scan/linear-scan-tests.factor | 191 ++++++++++++---- .../live-intervals/live-intervals.factor | 3 +- 4 files changed, 314 insertions(+), 99 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 908bf2475b..fa10ecfca4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences math math.order kernel assocs -accessors vectors fry heaps cpu.architecture combinators -compiler.cfg.registers -compiler.cfg.linear-scan.live-intervals ; +accessors vectors fry heaps cpu.architecture sorting locals +combinators compiler.cfg.registers +compiler.cfg.linear-scan.live-intervals hints ; IN: compiler.cfg.linear-scan.allocation ! Mapping from register classes to sequences of machine registers @@ -27,13 +27,61 @@ SYMBOL: active-intervals : delete-active ( live-interval -- ) dup vreg>> active-intervals-for delq ; -: expire-old-intervals ( n -- ) - active-intervals swap '[ - [ - [ end>> _ < ] partition - [ [ deallocate-register ] each ] dip - ] assoc-map - ] change ; +! Vector of inactive live intervals +SYMBOL: inactive-intervals + +: inactive-intervals-for ( vreg -- seq ) + reg-class>> inactive-intervals get at ; + +: add-inactive ( live-interval -- ) + dup vreg>> inactive-intervals-for push ; + +! Vector of handled live intervals +SYMBOL: handled-intervals + +: add-handled ( live-interval -- ) + handled-intervals get push ; + +: finished? ( n live-interval -- ? ) end>> swap < ; + +: finish ( n live-interval -- keep? ) + nip [ deallocate-register ] [ add-handled ] bi f ; + +: activate ( n live-interval -- keep? ) + nip add-active f ; + +: deactivate ( n live-interval -- keep? ) + nip add-inactive f ; + +: don't-change ( n live-interval -- keep? ) 2drop t ; + +! Moving intervals between active and inactive sets +: process-intervals ( n symbol quots -- ) + ! symbol stores an alist mapping register classes to vectors + [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline + +: covers? ( insn# live-interval -- ? ) + ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ; + +: deactivate-intervals ( n -- ) + ! Any active intervals which have ended are moved to handled + ! Any active intervals which cover the current position + ! are moved to inactive + active-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? not ] [ deactivate ] } + [ don't-change ] + } process-intervals ; + +: activate-intervals ( n -- ) + ! Any inactive intervals which have ended are moved to handled + ! Any inactive intervals which do not cover the current position + ! are moved to active + inactive-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? ] [ activate ] } + [ don't-change ] + } process-intervals ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -66,29 +114,64 @@ SYMBOL: progress : coalesce ( live-interval -- ) dup copy-from>> active-interval - [ [ add-active ] [ delete-active ] bi* ] + [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ] [ reg>> >>reg drop ] 2bi ; ! Splitting -: find-use ( live-interval n quot -- i elt ) - [ uses>> ] 2dip curry find ; inline +: split-range ( live-range n -- before after ) + [ [ from>> ] dip ] + [ 1 + swap to>> ] + 2bi ; -: split-before ( live-interval i -- before ) - [ clone dup uses>> ] dip - [ head >>uses ] [ 1- swap nth >>end ] 2bi ; +: split-last-range? ( last n -- ? ) + swap to>> <= ; -: split-after ( live-interval i -- after ) - [ clone dup uses>> ] dip - [ tail >>uses ] [ swap nth >>start ] 2bi - f >>reg f >>copy-from ; +: split-last-range ( before after last n -- before' after' ) + split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ; -: split-interval ( live-interval n -- before after ) - [ drop ] [ [ > ] find-use drop ] 2bi - [ split-before ] [ split-after ] 2bi ; +: split-ranges ( live-ranges n -- before after ) + [ '[ from>> _ <= ] partition ] + [ + pick empty? [ drop ] [ + [ over last ] dip 2dup split-last-range? + [ split-last-range ] [ 2drop ] if + ] if + ] bi ; + +: split-uses ( uses n -- before after ) + '[ _ <= ] partition ; : record-split ( live-interval before after -- ) - [ >>split-before ] [ >>split-after ] bi* drop ; + [ >>split-before ] [ >>split-after ] bi* drop ; inline + +: check-split ( live-interval -- ) + [ end>> ] [ start>> ] bi - 0 = + [ "BUG: splitting atomic interval" throw ] when ; inline + +: split-before ( before -- before' ) + [ [ ranges>> last ] [ uses>> last ] bi >>to drop ] + [ compute-start/end ] + [ ] + tri ; inline + +: split-after ( after -- after' ) + [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] + [ compute-start/end ] + [ ] + tri ; inline + +:: split-interval ( live-interval n -- before after ) + live-interval check-split + live-interval clone :> before + live-interval clone f >>copy-from f >>reg :> after + live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* + live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* + live-interval before after record-split + before split-before + after split-after ; + +HINTS: split-interval live-interval object ; ! Spilling SYMBOL: spill-counts @@ -96,6 +179,9 @@ SYMBOL: spill-counts : next-spill-location ( reg-class -- n ) spill-counts get [ dup 1+ ] change-at ; +: find-use ( live-interval n quot -- i elt ) + [ uses>> ] 2dip curry find ; inline + : interval-to-spill ( active-intervals current -- live-interval ) #! We spill the interval with the most distant use location. start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc @@ -108,8 +194,7 @@ SYMBOL: spill-counts [ >>spill-to ] [ >>reload-from ] bi-curry bi* ; : split-and-spill ( new existing -- before after ) - dup rot start>> split-interval - [ record-split ] [ assign-spill ] 2bi ; + swap start>> split-interval assign-spill ; : reuse-register ( new existing -- ) reg>> >>reg add-active ; @@ -121,7 +206,7 @@ SYMBOL: spill-counts #! of the existing interval again. [ reuse-register ] [ nip delete-active ] - [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ; + [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ; : spill-new ( new existing -- ) #! Our new interval will be used after the active interval @@ -141,37 +226,78 @@ SYMBOL: spill-counts : assign-free-register ( new registers -- ) pop >>reg add-active ; -: assign-register ( new -- ) - dup coalesce? [ - coalesce +: next-intersection ( new inactive -- n ) + 2drop 0 ; + +: intersecting-inactive ( new -- live-intervals ) + dup vreg>> inactive-intervals-for + [ tuck next-intersection ] with { } map>assoc ; + +: fits-in-hole ( new pair -- ) + first reuse-register ; + +: split-before-use ( new pair -- before after ) + ! Find optimal split position + second split-interval ; + +: assign-inactive-register ( new live-intervals -- ) + ! If there is an interval which is inactive for the entire lifetime + ! if the new interval, reuse its vreg. Otherwise, split new so that + ! the first half fits. + sort-values last + 2dup [ end>> ] [ second ] bi* < [ + fits-in-hole ] [ - dup vreg>> free-registers-for - [ assign-blocked-register ] - [ assign-free-register ] + [ split-before-use ] keep + '[ _ fits-in-hole ] [ add-unhandled ] bi* + ] if ; + +: assign-register ( new -- ) + dup coalesce? [ coalesce ] [ + dup vreg>> free-registers-for [ + dup intersecting-inactive + [ assign-blocked-register ] + [ assign-inactive-register ] + if-empty + ] [ assign-free-register ] if-empty ] if ; ! Main loop : reg-classes ( -- seq ) { int-regs double-float-regs } ; inline +: reg-class-assoc ( quot -- assoc ) + [ reg-classes ] dip { } map>assoc ; inline + : init-allocator ( registers -- ) - unhandled-intervals set [ reverse >vector ] assoc-map free-registers set - reg-classes [ 0 ] { } map>assoc spill-counts set - reg-classes [ V{ } clone ] { } map>assoc active-intervals set + [ 0 ] reg-class-assoc spill-counts set + unhandled-intervals set + [ V{ } clone ] reg-class-assoc active-intervals set + [ V{ } clone ] reg-class-assoc inactive-intervals set + V{ } clone handled-intervals set -1 progress set ; : handle-interval ( live-interval -- ) - [ start>> progress set ] - [ start>> expire-old-intervals ] - [ assign-register ] - tri ; + [ + start>> + [ progress set ] + [ deactivate-intervals ] + [ activate-intervals ] tri + ] [ assign-register ] bi ; : (allocate-registers) ( -- ) unhandled-intervals get [ handle-interval ] slurp-heap ; +: finish-allocation ( -- ) + ! Sanity check: all live intervals should've been processed + active-intervals inactive-intervals + [ get values [ handled-intervals get push-all ] each ] bi@ ; + : allocate-registers ( live-intervals machine-registers -- live-intervals ) #! This modifies the input live-intervals. init-allocator - dup init-unhandled - (allocate-registers) ; + init-unhandled + (allocate-registers) + finish-allocation + handled-intervals get ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0de350c215..4a9b0b231d 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -25,12 +25,7 @@ TUPLE: active-intervals seq ; SYMBOL: unhandled-intervals : add-unhandled ( live-interval -- ) - dup split-before>> [ - [ split-before>> ] [ split-after>> ] bi - [ add-unhandled ] bi@ - ] [ - dup start>> unhandled-intervals get heap-push - ] if ; + dup start>> unhandled-intervals get heap-push ; : init-unhandled ( live-intervals -- ) [ add-unhandled ] each ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e0cbe3774f..cf4daa3ab0 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.debugger ; +[ + { T{ live-range f 1 10 } T{ live-range f 15 15 } } + { T{ live-range f 16 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 15 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } T{ live-range f 15 16 } } + { T{ live-range f 17 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 16 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } } + { T{ live-range f 15 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 12 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } T{ live-range f 15 17 } } + { T{ live-range f 18 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 17 split-ranges +] unit-test + +[ + { } + { T{ live-range f 1 10 } } +] [ + { T{ live-range f 1 10 } } 0 split-ranges +] unit-test + +[ + { T{ live-range f 0 0 } } + { T{ live-range f 1 5 } } +] [ + { T{ live-range f 0 5 } } 0 split-ranges +] unit-test + [ 7 ] [ T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 2 } } } @@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ; [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 1 } - { uses V{ 0 1 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 1 } + { uses V{ 0 1 } } + { ranges V{ T{ live-range f 0 1 } } } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 5 } - { uses V{ 5 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + { ranges V{ T{ live-range f 5 5 } } } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + { ranges V{ T{ live-range f 0 5 } } } } 2 split-interval ] unit-test @@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ; { start 0 } { end 0 } { uses V{ 0 } } + { ranges V{ T{ live-range f 0 0 } } } } T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } { start 1 } { end 5 } { uses V{ 1 5 } } + { ranges V{ T{ live-range f 1 5 } } } } ] [ T{ live-interval @@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ; { start 0 } { end 5 } { uses V{ 0 1 5 } } + { ranges V{ T{ live-range f 0 5 } } } } 0 split-interval ] unit-test @@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 10 } + { uses V{ 0 10 } } + { ranges V{ T{ live-range f 0 10 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 11 } + { end 20 } + { uses V{ 11 20 } } + { ranges V{ T{ live-range f 11 20 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 60 } + { uses V{ 30 60 } } + { ranges V{ T{ live-range f 30 60 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 200 } + { uses V{ 30 200 } } + { ranges V{ T{ live-range f 30 200 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ; [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 100 } + { uses V{ 30 100 } } + { ranges V{ T{ live-range f 30 100 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ; test-cfg first optimize-cfg linear-scan drop ] unit-test -[ 0 1 ] [ - { - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 3 } - { end 4 } - { uses V{ 3 4 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } - { start 2 } - { end 6 } - { uses V{ 2 4 6 } } - } - } [ clone ] map - H{ { int-regs { "A" "B" } } } - allocate-registers - first split-before>> [ start>> ] [ end>> ] bi -] unit-test +: fake-live-ranges ( seq -- seq' ) + [ + clone dup [ start>> ] [ end>> ] bi 1vector >>ranges + ] map ; ! Coalescing interacted badly with splitting [ ] [ @@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ; { end 10 } { uses V{ 9 10 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 } } } allocate-registers drop ] unit-test @@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ; { end 109 } { uses V{ 103 109 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 4 } } } allocate-registers drop ] unit-test @@ -1193,7 +1286,7 @@ USING: math.private compiler.cfg.debugger ; { end 92 } { uses V{ 42 45 78 80 92 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 } } } allocate-registers drop ] unit-test diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 78ac9428d8..546443b289 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry -compiler.cfg.instructions compiler.cfg.registers +binary-search compiler.cfg.instructions compiler.cfg.registers compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals @@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals* : compute-start/end ( live-interval -- ) dup ranges>> [ first from>> ] [ last to>> ] bi + 2dup > [ "BUG: start > end" throw ] when [ >>start ] [ >>end ] bi* drop ; : finish-live-intervals ( live-intervals -- )