From 1e389c921d6bede8c4e72b34431ed4493d49047e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 29 Jul 2009 20:06:28 -0500 Subject: [PATCH 01/25] remove some leftover debug code from bunny shader --- extra/gpu/demos/bunny/sobel.f.glsl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/gpu/demos/bunny/sobel.f.glsl b/extra/gpu/demos/bunny/sobel.f.glsl index 16d2e408f2..7d21baf2d0 100644 --- a/extra/gpu/demos/bunny/sobel.f.glsl +++ b/extra/gpu/demos/bunny/sobel.f.glsl @@ -37,7 +37,7 @@ border_factor(vec2 texcoord) void main() { - gl_FragColor = /*vec4(border_factor(texcoord));*/ mix( + gl_FragColor = mix( texture2D(color_texture, texcoord), line_color, border_factor(texcoord) From d71e2f9577d347962c81462562167e6ab703f87b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 05:12:40 -0500 Subject: [PATCH 02/25] cpu.x86: Fix shuffle bug. Shuffling bugs occurring in code that runs before optimizer/stack checker is online are only caught at runtime during bootstrap, what a pain --- basis/cpu/x86/x86.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 6e21b46fd5..5bad8e067c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -281,7 +281,7 @@ M: x86.32 has-small-reg? { 32 [ drop t ] } } case ; -M: x86.64 has-small-reg? drop t ; +M: x86.64 has-small-reg? 2drop t ; : small-reg-that-isn't ( exclude -- reg' ) [ have-byte-regs ] dip From cd7a1d6c5837215a704a7179a69db7726e603b81 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 08:27:52 -0500 Subject: [PATCH 03/25] Oopsie --- basis/cpu/x86/64/unix/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index e48a20a9de..b6d56840e2 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs parser ; +cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; From be363d1a5b8090c5b01faf30bf488a3650226d1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 09:19:44 -0500 Subject: [PATCH 04/25] compiler.cfg: Get inline GC checks working again, using a dataflow analysis to compute uninitialized stack locations in compiler.cfg.stacks.uninitialized. Re-enable intrinsics which use inline allocation --- .../cfg/gc-checks/gc-checks-tests.factor | 26 +++++++ basis/compiler/cfg/gc-checks/gc-checks.factor | 28 ++++--- .../cfg/instructions/instructions.factor | 4 +- .../compiler/cfg/intrinsics/intrinsics.factor | 14 ++-- .../cfg/linearization/linearization.factor | 21 ++--- .../uninitialized/uninitialized-tests.factor | 61 +++++++++++++++ .../stacks/uninitialized/uninitialized.factor | 76 +++++++++++++++++++ basis/compiler/codegen/codegen.factor | 1 + basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/x86/x86.factor | 7 +- 10 files changed, 211 insertions(+), 29 deletions(-) create mode 100644 basis/compiler/cfg/gc-checks/gc-checks-tests.factor create mode 100644 basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor create mode 100644 basis/compiler/cfg/stacks/uninitialized/uninitialized.factor diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor new file mode 100644 index 0000000000..7b3e07faf8 --- /dev/null +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -0,0 +1,26 @@ +IN: compiler.cfg.gc-checks.tests +USING: compiler.cfg.gc-checks compiler.cfg.debugger +compiler.cfg.registers compiler.cfg.instructions compiler.cfg +compiler.cfg.predecessors cpu.architecture tools.test kernel vectors +namespaces accessors sequences ; + +: test-gc-checks ( -- ) + cfg new 0 get >>entry + compute-predecessors + insert-gc-checks + drop ; + +V{ + T{ ##inc-d f 3 } + T{ ##replace f V int-regs 0 D 1 } +} 0 test-bb + +V{ + T{ ##box-float f V int-regs 0 V int-regs 1 } +} 1 test-bb + +0 get 1 get 1vector >>successors drop + +[ ] [ test-gc-checks ] unit-test + +[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 8435a231e6..c34f2c42a3 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -1,17 +1,27 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences assocs -compiler.cfg.rpo compiler.cfg.instructions -compiler.cfg.hats ; +USING: accessors kernel sequences assocs fry +compiler.cfg.rpo +compiler.cfg.hats +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.gc-checks -: gc? ( bb -- ? ) +: insert-gc-check? ( bb -- ? ) instructions>> [ ##allocation? ] any? ; -: insert-gc-check ( basic-block -- ) - dup gc? [ - [ i i f \ ##gc new-insn prefix ] change-instructions drop - ] [ drop ] if ; +: blocks-with-gc ( cfg -- bbs ) + post-order [ insert-gc-check? ] filter ; + +: insert-gc-check ( bb -- ) + dup '[ + i i f _ uninitialized-locs \ ##gc new-insn + prefix + ] change-instructions drop ; : insert-gc-checks ( cfg -- cfg' ) - dup [ insert-gc-check ] each-basic-block ; \ No newline at end of file + dup blocks-with-gc [ + over compute-uninitialized-sets + [ insert-gc-check ] each + ] unless-empty ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index e08b3b25bb..0a52f1aa94 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ; INSN: ##fixnum-sub < ##fixnum-overflow ; INSN: ##fixnum-mul < ##fixnum-overflow ; -INSN: ##gc temp1 temp2 live-values ; +INSN: ##gc temp1 temp2 live-values uninitialized-locs ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; @@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ; TUPLE: spill-slot n ; C: spill-slot -INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ; +INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ; ! These instructions operate on machine registers and not ! virtual registers diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index c6642d8ad9..2618db0904 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics slots.private:set-slot strings.private:string-nth strings.private:set-string-nth-fast - ! classes.tuple.private: - ! arrays: - ! byte-arrays: - ! byte-arrays:(byte-array) - ! kernel: + classes.tuple.private: + arrays: + byte-arrays: + byte-arrays:(byte-array) + kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 alien.accessors:alien-signed-1 @@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-2 alien.accessors:alien-signed-2 alien.accessors:set-alien-signed-2 - ! alien.accessors:alien-cell + alien.accessors:alien-cell alien.accessors:set-alien-cell } [ t "intrinsic" set-word-prop ] each @@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } drop f [ t "intrinsic" set-word-prop ] each ; + } [ t "intrinsic" set-word-prop ] each ; : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 97fb3205c2..cbeb301901 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -98,15 +98,18 @@ M: ##dispatch linearize-insn M: ##gc linearize-insn nip - [ temp1>> ] - [ temp2>> ] - [ - live-values>> - [ compute-gc-roots ] - [ count-gc-roots ] - [ gc-roots-size ] - tri - ] tri + { + [ temp1>> ] + [ temp2>> ] + [ + live-values>> + [ compute-gc-roots ] + [ count-gc-roots ] + [ gc-roots-size ] + tri + ] + [ uninitialized-locs>> ] + } cleave _gc ; : linearize-basic-blocks ( cfg -- insns ) diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor new file mode 100644 index 0000000000..6f3e35994a --- /dev/null +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor @@ -0,0 +1,61 @@ +IN: compiler.cfg.stacks.uninitialized.tests +USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger +compiler.cfg.registers compiler.cfg.instructions compiler.cfg +compiler.cfg.predecessors cpu.architecture tools.test kernel vectors +namespaces accessors sequences ; + +: test-uninitialized ( -- ) + cfg new 0 get >>entry + compute-predecessors + compute-uninitialized-sets ; + +V{ + T{ ##inc-d f 3 } +} 0 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 0 D 2 } + T{ ##inc-r f 1 } +} 1 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##inc-d f 1 } +} 2 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop + +[ ] [ test-uninitialized ] unit-test + +[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test +[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test + +! When merging, if a location is uninitialized in one branch and +! initialized in another, we have to consider it uninitialized, +! since it cannot be safely read from by a ##peek, or traced by GC. + +V{ } 0 test-bb + +V{ + T{ ##inc-d f 1 } +} 1 test-bb + +V{ + T{ ##call f namestack } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##return } +} 3 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 3 get 1vector >>successors drop +2 get 3 get 1vector >>successors drop + +[ ] [ test-uninitialized ] unit-test + +[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor new file mode 100644 index 0000000000..ee60c4bd7a --- /dev/null +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences byte-arrays namespaces accessors classes math +math.order fry arrays combinators compiler.cfg.registers +compiler.cfg.instructions compiler.cfg.dataflow-analysis ; +IN: compiler.cfg.stacks.uninitialized + +! Uninitialized stack location analysis. + +! Consider the following sequence of instructions: +! ##inc-d 2 +! _gc +! ##replace ... D 0 +! ##replace ... D 1 +! The GC check runs before stack locations 0 and 1 have been initialized, +! and it needs to zero them out so that GC doesn't try to trace them. + + ] [ prepend ] } + } cond + ] change ; + +M: ##inc-d visit-insn n>> ds-loc handle-inc ; + +M: ##inc-r visit-insn n>> rs-loc handle-inc ; + +ERROR: uninitialized-peek insn ; + +M: ##peek visit-insn + dup loc>> [ n>> ] [ class get ] bi ?nth 0 = + [ uninitialized-peek ] [ drop ] if ; + +M: ##replace visit-insn + loc>> [ n>> ] [ class get ] bi + 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ; + +M: insn visit-insn drop ; + +: prepare ( pair -- ) + [ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if* + [ ds-loc set ] [ rs-loc set ] bi* ; + +: visit-block ( bb -- ) instructions>> [ visit-insn ] each ; + +: finish ( -- pair ) ds-loc get rs-loc get 2array ; + +: (join-sets) ( seq1 seq2 -- seq ) + 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ; + +: (uninitialized-locs) ( seq quot -- seq' ) + [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline + +PRIVATE> + +FORWARD-ANALYSIS: uninitialized + +M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) + drop [ prepare ] dip visit-block finish ; + +M: uninitialized-analysis join-sets ( sets analysis -- pair ) + drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; + +: uninitialized-locs ( bb -- locs ) + uninitialized-in dup [ + first2 + [ [ ] (uninitialized-locs) ] + [ [ ] (uninitialized-locs) ] + bi* append + ] when ; \ No newline at end of file diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index f9a4786eb5..c387c4ed8d 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -221,6 +221,7 @@ M: _gc generate-insn [ temp2>> ] [ gc-roots>> ] [ gc-root-count>> ] + [ uninitialized-locs>> ] } cleave %gc ; M: _loop-entry generate-insn drop %loop-entry ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index deb44db41a..b22e91056f 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -128,7 +128,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 ( temp1 temp2 live-registers live-spill-slots -- ) +HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots uninitialized-locs -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 5bad8e067c..4fad6d4efc 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -466,6 +466,10 @@ M:: word load-gc-root ( gc-root register temp -- ) : load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ; +: wipe-locs ( locs -- ) + ! See explanation in compiler.cfg.stacks.uninitialized + [ 0 ] dip [ %replace ] with each ; + :: call-gc ( gc-root-count -- ) ! Pass pointer to start of GC roots as first parameter param-reg-1 gc-root-base param@ LEA @@ -475,11 +479,12 @@ M:: word load-gc-root ( gc-root register temp -- ) %prepare-alien-invoke "inline_gc" f %alien-invoke ; -M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- ) +M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count uninitialized-locs -- ) "end" define-label temp1 temp2 check-nursery "end" get JLE gc-roots temp1 save-gc-roots + uninitialized-locs wipe-locs gc-root-count call-gc gc-roots temp1 load-gc-roots "end" resolve-label ; From cc11727627d127718179f3d52ad388b40fb55bbf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 09:24:41 -0500 Subject: [PATCH 05/25] benchmark.pidigits: reduce parameter to speed up CI runs --- extra/benchmark/pidigits/pidigits.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor index 0f8a98e6f9..d001d81a8c 100644 --- a/extra/benchmark/pidigits/pidigits.factor +++ b/extra/benchmark/pidigits/pidigits.factor @@ -54,6 +54,6 @@ IN: benchmark.pidigits [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ; : pidigits-main ( -- ) - 10000 pidigits ; + 2000 pidigits ; MAIN: pidigits-main From c7dde45c2a597a93d6b62734351dfd6a562814fb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 10:58:34 -0500 Subject: [PATCH 06/25] hyphens>underscores in VERTEX-FORMAT for consistency with UNIFORM-TUPLE --- extra/gpu/render/render.factor | 4 +--- extra/gpu/shaders/shaders.factor | 16 +++++++++------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index ce6e0e25ff..8f1679bfa8 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -8,7 +8,7 @@ gpu.textures gpu.textures.private half-floats images kernel lexer locals math math.order math.parser namespaces opengl opengl.gl parser quotations sequences slots sorting specialized-arrays.alien specialized-arrays.float specialized-arrays.int -specialized-arrays.uint strings tr ui.gadgets.worlds variants +specialized-arrays.uint strings ui.gadgets.worlds variants vocabs.parser words ; IN: gpu.render @@ -338,8 +338,6 @@ DEFER: [bind-uniform-tuple] texture-unit' value>>-quot { value-cleave 2cleave } append ; -TR: hyphens>underscores "-" "_" ; - :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot ) prefix uniform name>> append hyphens>underscores :> name uniform uniform-type>> :> type diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index d2dd29595a..58633d4a71 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -8,7 +8,7 @@ io.encodings.ascii io.files io.pathnames kernel lexer literals locals math math.parser memoize multiline namespaces opengl opengl.gl opengl.shaders parser quotations sequences specialized-arrays.alien specialized-arrays.int splitting -strings ui.gadgets.worlds variants vectors vocabs vocabs.loader +strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader vocabs.parser words words.constant ; IN: gpu.shaders @@ -65,6 +65,8 @@ MEMO: output-index ( program-instance output-name -- index ) underscores "-" "_" ; + : gl-vertex-type ( component-type -- gl-type ) { { ubyte-components [ GL_UNSIGNED_BYTE ] } @@ -125,12 +127,12 @@ MEMO: output-index ( program-instance output-name -- index ) } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ; :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot ) - vertex-attribute name>> :> name - vertex-attribute component-type>> :> type - type gl-vertex-type :> gl-type - vertex-attribute dim>> :> dim - vertex-attribute normalize?>> >c-bool :> normalize? - vertex-attribute vertex-attribute-size :> size + vertex-attribute name>> hyphens>underscores :> name + vertex-attribute component-type>> :> type + type gl-vertex-type :> gl-type + vertex-attribute dim>> :> dim + vertex-attribute normalize?>> >c-bool :> normalize? + vertex-attribute vertex-attribute-size :> size stride offset size + { From 455956b16c917b6e6f9809ea1288296b04714466 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 11:05:12 -0500 Subject: [PATCH 07/25] add additional SSE2 packed integer operations --- .../cpu/x86/assembler/assembler-tests.factor | 1 + basis/cpu/x86/assembler/assembler.factor | 76 ++++++++++++++++--- 2 files changed, 67 insertions(+), 10 deletions(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 66adee6bf6..1fe65b719c 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -68,6 +68,7 @@ IN: cpu.x86.assembler.tests ! sse shift instructions [ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: d1 HEX: c1 } ] [ [ XMM0 XMM1 PSRLW ] { } make ] unit-test ! sse comparison instructions [ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index e91ebdcb1a..1bcf672ce7 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -681,24 +681,57 @@ ALIAS: PINSRQ PINSRD : MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ; : MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ; : MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ; +: PUNPCKLBW ( dest src -- ) HEX: 60 HEX: 66 2-operand-rm-sse ; +: PUNPCKLWD ( dest src -- ) HEX: 61 HEX: 66 2-operand-rm-sse ; +: PUNPCKLDQ ( dest src -- ) HEX: 62 HEX: 66 2-operand-rm-sse ; +: PACKSSWB ( dest src -- ) HEX: 63 HEX: 66 2-operand-rm-sse ; +: PCMPGTB ( dest src -- ) HEX: 64 HEX: 66 2-operand-rm-sse ; +: PCMPGTW ( dest src -- ) HEX: 65 HEX: 66 2-operand-rm-sse ; +: PCMPGTD ( dest src -- ) HEX: 66 HEX: 66 2-operand-rm-sse ; +: PACKUSWB ( dest src -- ) HEX: 67 HEX: 66 2-operand-rm-sse ; +: PUNPCKHBW ( dest src -- ) HEX: 68 HEX: 66 2-operand-rm-sse ; +: PUNPCKHWD ( dest src -- ) HEX: 69 HEX: 66 2-operand-rm-sse ; +: PUNPCKHDQ ( dest src -- ) HEX: 6a HEX: 66 2-operand-rm-sse ; +: PACKSSDW ( dest src -- ) HEX: 6b HEX: 66 2-operand-rm-sse ; : PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ; : PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ; +: MOVD ( dest src -- ) { HEX: 6e HEX: 7e } HEX: 66 2-operand-rm-mr-sse ; : MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; : MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; : PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ; : PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; : PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; -: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ; -: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; -: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; -: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ; -: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ; -: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ; -: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ; + +: (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ; +: (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; +: (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; +: (PSRLD-imm) ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ; +: (PSRAD-imm) ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ; +: (PSLLD-imm) ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ; +: (PSRLQ-imm) ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ; +: (PSLLQ-imm) ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ; + +: (PSRLW-reg) ( dest src -- ) HEX: d1 HEX: 66 2-operand-rm-sse ; +: (PSRLD-reg) ( dest src -- ) HEX: d2 HEX: 66 2-operand-rm-sse ; +: (PSRLQ-reg) ( dest src -- ) HEX: d3 HEX: 66 2-operand-rm-sse ; +: (PSRAW-reg) ( dest src -- ) HEX: e1 HEX: 66 2-operand-rm-sse ; +: (PSRAD-reg) ( dest src -- ) HEX: e2 HEX: 66 2-operand-rm-sse ; +: (PSLLW-reg) ( dest src -- ) HEX: f1 HEX: 66 2-operand-rm-sse ; +: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ; +: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ; + +: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ; +: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ; +: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ; +: PSRLD ( dest src -- ) dup integer? [ (PSRLD-imm) ] [ (PSRLD-reg) ] if ; +: PSRAD ( dest src -- ) dup integer? [ (PSRAD-imm) ] [ (PSRAD-reg) ] if ; +: PSLLD ( dest src -- ) dup integer? [ (PSLLD-imm) ] [ (PSLLD-reg) ] if ; +: PSRLQ ( dest src -- ) dup integer? [ (PSRLQ-imm) ] [ (PSRLQ-reg) ] if ; +: PSLLQ ( dest src -- ) dup integer? [ (PSLLQ-imm) ] [ (PSLLQ-reg) ] if ; + : PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ; -: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ; : PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ; : PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ; @@ -709,11 +742,14 @@ ALIAS: PINSRQ PINSRD : HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ; : HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ; +: FXSAVE ( dest -- ) { BIN: 000 f { HEX: 0f HEX: ae } } 1-operand ; +: FXRSTOR ( src -- ) { BIN: 001 f { HEX: 0f HEX: ae } } 1-operand ; : LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ; : STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ; : LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ; : MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ; : SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ; +: CLFLUSH ( dest -- ) { BIN: 111 f { HEX: 0f HEX: ae } } 1-operand ; : POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ; @@ -762,26 +798,46 @@ ALIAS: PINSRQ PINSRD : ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; : ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; : PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ; +: PMULLW ( dest src -- ) HEX: d5 HEX: 66 2-operand-rm-sse ; +: PMOVMSKB ( dest src -- ) HEX: d7 HEX: 66 2-operand-rm-sse ; +: PSUBUSB ( dest src -- ) HEX: d8 HEX: 66 2-operand-rm-sse ; +: PSUBUSW ( dest src -- ) HEX: d9 HEX: 66 2-operand-rm-sse ; : PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ; +: PAND ( dest src -- ) HEX: db HEX: 66 2-operand-rm-sse ; +: PADDUSB ( dest src -- ) HEX: dc HEX: 66 2-operand-rm-sse ; +: PADDUSW ( dest src -- ) HEX: dd HEX: 66 2-operand-rm-sse ; : PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ; +: PANDN ( dest src -- ) HEX: df HEX: 66 2-operand-rm-sse ; : PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ; : PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ; : PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ; +: PMULHW ( dest src -- ) HEX: e5 HEX: 66 2-operand-rm-sse ; : CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ; : CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ; : CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ; : MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ; +: PSUBSB ( dest src -- ) HEX: e8 HEX: 66 2-operand-rm-sse ; +: PSUBSW ( dest src -- ) HEX: e9 HEX: 66 2-operand-rm-sse ; : PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ; +: POR ( dest src -- ) HEX: eb HEX: 66 2-operand-rm-sse ; +: PADDSB ( dest src -- ) HEX: ec HEX: 66 2-operand-rm-sse ; +: PADDSW ( dest src -- ) HEX: ed HEX: 66 2-operand-rm-sse ; : PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ; +: PXOR ( dest src -- ) HEX: ef HEX: 66 2-operand-rm-sse ; : LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ; : PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ; +: PMADDWD ( dest src -- ) HEX: f5 HEX: 66 2-operand-rm-sse ; : PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ; - : MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ; - +: PSUBB ( dest src -- ) HEX: f8 HEX: 66 2-operand-rm-sse ; +: PSUBW ( dest src -- ) HEX: f9 HEX: 66 2-operand-rm-sse ; +: PSUBD ( dest src -- ) HEX: fa HEX: 66 2-operand-rm-sse ; : PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ; +: PADDB ( dest src -- ) HEX: fc HEX: 66 2-operand-rm-sse ; +: PADDW ( dest src -- ) HEX: fd HEX: 66 2-operand-rm-sse ; +: PADDD ( dest src -- ) HEX: fe HEX: 66 2-operand-rm-sse ; ! x86-64 branch prediction hints From 9c9132297f44b9a5b629ac17f85b75a7451eeeaf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 20:57:22 -0500 Subject: [PATCH 08/25] no need to call set-gpu-state* directly --- extra/gpu/demos/bunny/bunny.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index f975b21245..48f74df6ce 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -221,7 +221,7 @@ BEFORE: bunny-world begin-world bunny-uniforms boa ; : draw-bunny ( world -- ) - T{ depth-state { comparison cmp-less } } set-gpu-state* + T{ depth-state { comparison cmp-less } } set-gpu-state [ sobel>> framebuffer>> { @@ -247,7 +247,7 @@ BEFORE: bunny-world begin-world sobel-uniforms boa ; : draw-sobel ( world -- ) - T{ depth-state { comparison f } } set-gpu-state* + T{ depth-state { comparison f } } set-gpu-state sobel>> { { "primitive-mode" [ drop triangle-strip-mode ] } @@ -260,7 +260,7 @@ BEFORE: bunny-world begin-world [ draw-bunny ] [ draw-sobel ] bi ; : draw-loading ( world -- ) - T{ depth-state { comparison f } } set-gpu-state* + T{ depth-state { comparison f } } set-gpu-state loading>> { { "primitive-mode" [ drop triangle-strip-mode ] } From dd3c90bf1182fd94039e26ccb1853daddaa3beeb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 20:58:32 -0500 Subject: [PATCH 09/25] add file-stem word to io.pathnames as the counterpart to file-extension. write docs for both --- core/io/pathnames/pathnames-docs.factor | 20 ++++++++++++++++++++ core/io/pathnames/pathnames.factor | 5 ++++- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index 733283d298..63a905d578 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -23,6 +23,24 @@ HELP: file-name { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +HELP: file-extension +{ $values { "path" "a pathname string" } { "extension" string } } +{ $description "Outputs the extension of " { $snippet "path" } ", or " { $link f } " if the filename has no extension." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-extension ." "f" } + { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-extension ." "\"vbs\"" } +} ; + +HELP: file-stem +{ $values { "path" "a pathname string" } { "stem" string } } +{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" } + { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" } +} ; + +{ file-name file-stem file-extension } related-words + HELP: path-components { $values { "path" "a pathnames string" } { "seq" sequence } } { $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ; @@ -86,6 +104,8 @@ ARTICLE: "io.pathnames" "Pathname manipulation" "Pathname manipulation:" { $subsection parent-directory } { $subsection file-name } +{ $subsection file-stem } +{ $subsection file-extension } { $subsection last-path-separator } { $subsection path-components } { $subsection prepend-path } diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 30e9e6c206..6a49ed5797 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -118,7 +118,10 @@ PRIVATE> ] if ] unless ; -: file-extension ( filename -- extension ) +: file-stem ( path -- stem ) + file-name "." split1-last drop ; + +: file-extension ( path -- extension ) file-name "." split1-last nip ; : path-components ( path -- seq ) From 47920a7a0c937021978c287bf3c22db2d6510c64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 21:27:52 -0500 Subject: [PATCH 10/25] Passing -profile-compiler switch to bootstrap collects timing information from optimizer passes --- basis/bootstrap/compiler/compiler.factor | 4 ++ basis/bootstrap/compiler/timing/timing.factor | 38 +++++++++++++++++++ 2 files changed, 42 insertions(+) create mode 100644 basis/bootstrap/compiler/timing/timing.factor diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0a3ff10a8e..4394535b8d 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -10,6 +10,10 @@ math.order quotations quotations.private assocs.private ; FROM: compiler => enable-optimizer ; IN: bootstrap.compiler +"profile-compiler" get [ + "bootstrap.compiler.timing" require +] when + ! Don't bring this in when deploying, since it will store a ! reference to 'eval' in a global variable "deploy-vocab" get "staging" get or [ diff --git a/basis/bootstrap/compiler/timing/timing.factor b/basis/bootstrap/compiler/timing/timing.factor new file mode 100644 index 0000000000..e1466e3409 --- /dev/null +++ b/basis/bootstrap/compiler/timing/timing.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors compiler.cfg.builder compiler.cfg.linear-scan +compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer +compiler.cfg.stacks.finalize compiler.cfg.stacks.global +compiler.codegen compiler.tree.builder compiler.tree.optimizer +kernel make sequences tools.annotations tools.crossref ; +IN: bootstrap.compiler.timing + +: passes ( word -- seq ) + def>> uses [ vocabulary>> "compiler." head? ] filter ; + +: high-level-passes ( -- seq ) \ optimize-tree passes ; + +: low-level-passes ( -- seq ) \ optimize-cfg passes ; + +: machine-passes ( -- seq ) \ build-mr passes ; + +: linear-scan-passes ( -- seq ) \ (linear-scan) passes ; + +: all-passes ( -- seq ) + [ + \ build-tree , + \ optimize-tree , + high-level-passes % + \ build-cfg , + \ compute-global-sets , + \ finalize-stack-shuffling , + \ optimize-cfg , + low-level-passes % + \ compute-live-sets , + \ build-mr , + machine-passes % + linear-scan-passes % + \ generate , + ] { } make ; + +all-passes [ [ reset ] [ add-timing ] bi ] each \ No newline at end of file From 45770c62504cf68f11c1fc61e89eea0bf51c4336 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 21:28:27 -0500 Subject: [PATCH 11/25] Move a bunch of GC check generation logic to platform-independent side --- basis/compiler/codegen/codegen.factor | 44 +++++++++++++++++---- basis/cpu/architecture/architecture.factor | 7 +++- basis/cpu/x86/x86.factor | 45 +++------------------- 3 files changed, 49 insertions(+), 47 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c387c4ed8d..672ed9ce02 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture classes +continuations.private fry cpu.architecture classes locals source-files.errors compiler.errors compiler.alien @@ -215,14 +215,44 @@ M: ##write-barrier generate-insn [ table>> ] tri %write-barrier ; +! GC checks +: wipe-locs ( locs temp -- ) + '[ + _ + [ 0 %load-immediate ] + [ swap [ %replace ] with each ] bi + ] unless-empty ; + +GENERIC# save-gc-root 1 ( gc-root operand temp -- ) + +M:: spill-slot save-gc-root ( gc-root operand temp -- ) + temp operand n>> %reload-integer + gc-root temp %save-gc-root ; + +M: object save-gc-root drop %save-gc-root ; + +: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ; + +GENERIC# load-gc-root 1 ( gc-root operand temp -- ) + +M:: spill-slot load-gc-root ( gc-root operand temp -- ) + gc-root temp %load-gc-root + temp operand n>> %spill-integer ; + +M: object load-gc-root drop %load-gc-root ; + +: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ; + M: _gc generate-insn + "no-gc" define-label { - [ temp1>> ] - [ temp2>> ] - [ gc-roots>> ] - [ gc-root-count>> ] - [ uninitialized-locs>> ] - } cleave %gc ; + [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ] + [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ] + [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ] + [ gc-root-count>> %call-gc ] + [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ] + } cleave + "no-gc" resolve-label ; M: _loop-entry generate-insn drop %loop-entry ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b22e91056f..e4c8f3246d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -128,7 +128,12 @@ HOOK: %alien-global cpu ( dst symbol library -- ) HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) -HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots uninitialized-locs -- ) + +! GC checks +HOOK: %check-nursery cpu ( label temp1 temp2 -- ) +HOOK: %save-gc-root cpu ( gc-root register -- ) +HOOK: %load-gc-root cpu ( gc-root register -- ) +HOOK: %call-gc cpu ( gc-root-count -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 4fad6d4efc..34b1b63581 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -435,42 +435,19 @@ M:: x86 %write-barrier ( src card# table -- ) table table [] MOV table card# [+] card-mark MOV ; -:: check-nursery ( temp1 temp2 -- ) +M:: x86 %check-nursery ( label temp1 temp2 -- ) temp1 load-zone-ptr temp2 temp1 cell [+] MOV temp2 1024 ADD temp1 temp1 3 cells [+] MOV - temp2 temp1 CMP ; + temp2 temp1 CMP + label JLE ; -GENERIC# save-gc-root 1 ( gc-root operand temp -- ) +M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ; -M:: spill-slot save-gc-root ( gc-root spill-slot temp -- ) - temp spill-slot n>> spill-integer@ MOV - gc-root gc-root@ temp MOV ; +M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ 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 ; - -: wipe-locs ( locs -- ) - ! See explanation in compiler.cfg.stacks.uninitialized - [ 0 ] dip [ %replace ] with each ; - -:: call-gc ( gc-root-count -- ) +M:: x86 %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 @@ -479,16 +456,6 @@ M:: word load-gc-root ( gc-root register temp -- ) %prepare-alien-invoke "inline_gc" f %alien-invoke ; -M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count uninitialized-locs -- ) - "end" define-label - temp1 temp2 check-nursery - "end" get JLE - gc-roots temp1 save-gc-roots - uninitialized-locs wipe-locs - 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 ; From dd2dc2bb24ef116d7a2a27f1e7d2903e64a2f07c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 21:44:22 -0500 Subject: [PATCH 12/25] cpu.ppc: Updating PowerPC backend for codegen changes over the last two months: new shift intrinsics added, fixnum overflow intrinsics are now treated like conditionals, GC checks are more complex and have a different API --- basis/cpu/ppc/ppc.factor | 144 ++++++++++++--------------------------- 1 file changed, 44 insertions(+), 100 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 003eccfa18..7ce73d2c4b 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -76,8 +76,12 @@ HOOK: reserved-area-size os ( -- n ) : xt-save ( n -- i ) 2 cells - ; ! Next, we have the spill area as well as the FFI parameter area. -! They overlap, since basic blocks with FFI calls will never -! spill. +! It is safe for them to overlap, since basic blocks with FFI calls +! will never spill -- indeed, basic blocks with FFI calls do not +! use vregs at all, and the FFI call is a stack analysis sync point. +! In the future this will change and the stack frame logic will +! need to be untangled somewhat. + : param@ ( n -- x ) reserved-area-size + ; inline : param-save-size ( -- n ) 8 cells ; foldable @@ -85,32 +89,30 @@ HOOK: reserved-area-size os ( -- n ) : local@ ( n -- x ) reserved-area-size param-save-size + + ; inline -: spill-integer-base ( -- n ) - stack-frame get spill-counts>> double-float-regs swap at - double-float-regs reg-size * ; - : spill-integer@ ( n -- offset ) - cells spill-integer-base + param@ ; + spill-integer-offset param@ ; : spill-float@ ( n -- offset ) - double-float-regs reg-size * param@ ; + spill-float-offset param@ ; ! Some FP intrinsics need a temporary scratch area in the stack -! frame, 8 bytes in size +! frame, 8 bytes in size. This is in the param-save area so it +! should not overlap with spill slots. : scratch@ ( n -- offset ) stack-frame get total-size>> factor-area-size - param-save-size - + ; +! GC root area +: gc-root@ ( n -- offset ) + gc-root-offset param@ ; + ! Finally we have the linkage area HOOK: lr-save os ( -- n ) M: ppc stack-frame-size ( stack-frame -- i ) - [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] - [ params>> ] - [ return>> ] - tri + + + (stack-frame-size) param-save-size + reserved-area-size + factor-area-size + @@ -176,95 +178,28 @@ M: ppc %or OR ; M: ppc %or-imm ORI ; M: ppc %xor XOR ; M: ppc %xor-imm XORI ; +M: ppc %shl SLW ; M: ppc %shl-imm swapd SLWI ; +M: ppc %shr-imm SRW ; M: ppc %shr-imm swapd SRWI ; +M: ppc %sar SRAW ; M: ppc %sar-imm SRAWI ; M: ppc %not NOT ; -: %alien-invoke-tail ( func dll -- ) - [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ; - -:: exchange-regs ( r1 r2 -- ) - scratch-reg r1 MR - r1 r2 MR - r2 scratch-reg MR ; - -: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ; - -:: move>args ( src1 src2 -- ) - { - { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] } - { [ src1 3 = ] [ 4 src2 ?MR ] } - { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] } - { [ src2 4 = ] [ 3 src1 ?MR ] } - [ 3 src1 MR 4 src2 MR ] - } cond ; - -: clear-xer ( -- ) +:: overflow-template ( label dst src1 src2 insn -- ) 0 0 LI - 0 MTXER ; inline + 0 MTXER + dst src2 src1 insn call + label BNO ; inline -:: overflow-template ( src1 src2 insn func -- ) - "no-overflow" define-label - clear-xer - scratch-reg src2 src1 insn call - scratch-reg ds-reg 0 STW - "no-overflow" get BNO - src1 src2 move>args - %prepare-alien-invoke - func f %alien-invoke - "no-overflow" resolve-label ; inline +M: ppc %fixnum-add ( label dst src1 src2 -- ) + [ ADDO. ] overflow-template ; -:: overflow-template-tail ( src1 src2 insn func -- ) - "overflow" define-label - clear-xer - scratch-reg src2 src1 insn call - "overflow" get BO - scratch-reg ds-reg 0 STW - BLR - "overflow" resolve-label - src1 src2 move>args - %prepare-alien-invoke - func f %alien-invoke-tail ; inline +M: ppc %fixnum-sub ( label dst src1 src2 -- ) + [ SUBFO. ] overflow-template ; -M: ppc %fixnum-add ( src1 src2 -- ) - [ ADDO. ] "overflow_fixnum_add" overflow-template ; - -M: ppc %fixnum-add-tail ( src1 src2 -- ) - [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ; - -M: ppc %fixnum-sub ( src1 src2 -- ) - [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ; - -M: ppc %fixnum-sub-tail ( src1 src2 -- ) - [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ; - -M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- ) - "no-overflow" define-label - clear-xer - temp1 src1 tag-bits get SRAWI - temp2 temp1 src2 MULLWO. - temp2 ds-reg 0 STW - "no-overflow" get BNO - src2 src2 tag-bits get SRAWI - temp1 src2 move>args - %prepare-alien-invoke - "overflow_fixnum_multiply" f %alien-invoke - "no-overflow" resolve-label ; - -M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- ) - "overflow" define-label - clear-xer - temp1 src1 tag-bits get SRAWI - temp2 temp1 src2 MULLWO. - "overflow" get BO - temp2 ds-reg 0 STW - BLR - "overflow" resolve-label - src2 src2 tag-bits get SRAWI - temp1 src2 move>args - %prepare-alien-invoke - "overflow_fixnum_multiply" f %alien-invoke-tail ; +M:: ppc %fixnum-mul ( label dst src1 src2 -- ) + [ MULLWO. ] overflow-template ; : bignum@ ( n -- offset ) cells bignum tag-number - ; inline @@ -462,17 +397,26 @@ M:: ppc %write-barrier ( src card# table -- ) src card# deck-bits SRWI table scratch-reg card# STBX ; -M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- ) - "end" define-label +M:: ppc %check-nursery ( label temp1 temp2 -- ) temp2 load-zone-ptr temp1 temp2 cell LWZ temp2 temp2 3 cells LWZ - temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here - temp1 0 temp2 CMP ! is here >= end? - "end" get BLE + ! add ALLOT_BUFFER_ZONE to here + temp1 temp1 1024 ADDI + ! is here >= end? + temp1 0 temp2 CMP + label BLE ; + +M:: ppc %save-gc-root ( gc-root register -- ) + register 1 gc-root gc-root@ STW ; + +M:: ppc %load-gc-root ( gc-root register -- ) + register 1 gc-root gc-root@ LWZ ; + +M:: ppc %call-gc ( gc-root-count -- ) %prepare-alien-invoke - 0 3 LI - 0 4 LI + 3 1 gc-root-base param@ ADDI + gc-root-count 4 LI "inline_gc" f %alien-invoke "end" resolve-label ; From 5e6936ec6980330cc776a8089b0fdbfa715b3121 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Jul 2009 23:20:38 -0500 Subject: [PATCH 13/25] README.txt: minor updates suggested by mnestic --- README.txt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/README.txt b/README.txt index a33a85b218..016d60e68c 100755 --- a/README.txt +++ b/README.txt @@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc, Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev + sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev + +Note that if you are using a proprietary OpenGL driver, you should +probably leave out the last package in the list. If your DISPLAY environment variable is set, the UI will start -automatically: +automatically when you run Factor: ./factor From 918b95dfc75d899046ccf878d9747434409cf11a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 31 Jul 2009 15:34:29 -0500 Subject: [PATCH 14/25] fix some lousy docs in gpu.textures --- extra/gpu/textures/textures-docs.factor | 14 +++++++++----- extra/gpu/textures/textures.factor | 4 ++-- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/extra/gpu/textures/textures-docs.factor b/extra/gpu/textures/textures-docs.factor index 8f3bb361a5..6a14a5728b 100644 --- a/extra/gpu/textures/textures-docs.factor +++ b/extra/gpu/textures/textures-docs.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: byte-arrays classes gpu.buffers help.markup help.syntax +USING: alien byte-arrays classes gpu.buffers help.markup help.syntax images kernel math ; IN: gpu.textures @@ -228,7 +228,11 @@ HELP: texture-cube-map { texture-cube-map } related-words HELP: texture-data -{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." } +{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } "." +{ $list +{ "The " { $snippet "ptr" } " slot references either CPU memory (as a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } " that contains the image data." } +{ "The " { $snippet "component-order" } " and " { $snippet "component-type" } " slots determine the " { $link component-order } " and " { $link component-type } " of the referenced data." } +} } { $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ; { texture-data } related-words @@ -254,15 +258,15 @@ HELP: texture-filter { $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ; HELP: texture-parameters -{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:" +{ $class-description "A " { $snippet "texture-parameters" } " tuple is supplied when constructing a " { $link texture } " to control the wrapping, filtering, and level-of-detail handling of the texture. These tuples have the following slots:" { $list { "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." } -{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." } +{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among the sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." } { "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." } { "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." } { "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." } { "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." } -{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." } +{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithms of the dimensions of the highest level of detail image." } } } ; { texture-parameters set-texture-parameters } related-words diff --git a/extra/gpu/textures/textures.factor b/extra/gpu/textures/textures.factor index c84f3a2123..a2e6ffd440 100644 --- a/extra/gpu/textures/textures.factor +++ b/extra/gpu/textures/textures.factor @@ -26,14 +26,14 @@ TUPLE: cube-map-face { axis cube-map-axis read-only } ; C: cube-map-face -UNION: texture-data-target - texture-1d texture-2d texture-3d cube-map-face ; UNION: texture-1d-data-target texture-1d ; UNION: texture-2d-data-target texture-2d texture-rectangle texture-1d-array cube-map-face ; UNION: texture-3d-data-target texture-3d texture-2d-array ; +UNION: texture-data-target + texture-1d-data-target texture-2d-data-target texture-3d-data-target ; M: texture dispose [ [ delete-texture ] when* f ] change-handle drop ; From 3258f9c4efbbe410354c77a4283a8e21209d802b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 31 Jul 2009 16:27:18 -0500 Subject: [PATCH 15/25] fix using list on win64 --- basis/cpu/x86/64/winnt/winnt.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 8091be65ae..44e8568658 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts system math alien.c-types sequences -compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ; +compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 +cpu.x86.assembler.operands ; IN: cpu.x86.64.winnt M: int-regs param-regs drop { RCX RDX R8 R9 } ; From 957a5b7b9bec29e46d2a2c0c2ee96dea1ab74900 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 17:57:15 -0500 Subject: [PATCH 16/25] cpu.ppc: fix small typos --- basis/cpu/ppc/ppc.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 7ce73d2c4b..294de707fb 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -4,10 +4,10 @@ USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words alien alien.accessors alien.c-types literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers -compiler.cfg.instructions compiler.constants compiler.codegen +compiler.cfg.instructions compiler.cfg.comparisons compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame compiler.cfg.build-stack-frame -compiler.units ; +compiler.units compiler.constants compiler.codegen ; FROM: cpu.ppc.assembler => B ; IN: cpu.ppc @@ -180,7 +180,7 @@ M: ppc %xor XOR ; M: ppc %xor-imm XORI ; M: ppc %shl SLW ; M: ppc %shl-imm swapd SLWI ; -M: ppc %shr-imm SRW ; +M: ppc %shr SRW ; M: ppc %shr-imm swapd SRWI ; M: ppc %sar SRAW ; M: ppc %sar-imm SRAWI ; @@ -190,7 +190,7 @@ M: ppc %not NOT ; 0 0 LI 0 MTXER dst src2 src1 insn call - label BNO ; inline + label BO ; inline M: ppc %fixnum-add ( label dst src1 src2 -- ) [ ADDO. ] overflow-template ; @@ -198,7 +198,7 @@ M: ppc %fixnum-add ( label dst src1 src2 -- ) M: ppc %fixnum-sub ( label dst src1 src2 -- ) [ SUBFO. ] overflow-template ; -M:: ppc %fixnum-mul ( label dst src1 src2 -- ) +M: ppc %fixnum-mul ( label dst src1 src2 -- ) [ MULLWO. ] overflow-template ; : bignum@ ( n -- offset ) cells bignum tag-number - ; inline @@ -417,8 +417,7 @@ M:: ppc %call-gc ( gc-root-count -- ) %prepare-alien-invoke 3 1 gc-root-base param@ ADDI gc-root-count 4 LI - "inline_gc" f %alien-invoke - "end" resolve-label ; + "inline_gc" f %alien-invoke ; M: ppc %prologue ( n -- ) 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this From d515715b0cb00677466f473484e8de06a927639b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 18:34:15 -0500 Subject: [PATCH 17/25] compiler.cfg.ssa.destruction: fix bug in renaming triggered by sequence-parser:take-sequence --- .../cfg/ssa/destruction/copies/copies.factor | 4 ++-- .../cfg/ssa/destruction/destruction.factor | 2 +- .../process-blocks/process-blocks.factor | 2 +- .../cfg/ssa/destruction/state/state.factor | 2 ++ basis/compiler/tests/codegen.factor | 17 +++++++++++++++-- 5 files changed, 21 insertions(+), 6 deletions(-) diff --git a/basis/compiler/cfg/ssa/destruction/copies/copies.factor b/basis/compiler/cfg/ssa/destruction/copies/copies.factor index 063704e0f6..177793f1a1 100644 --- a/basis/compiler/cfg/ssa/destruction/copies/copies.factor +++ b/basis/compiler/cfg/ssa/destruction/copies/copies.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs hashtables fry kernel make namespaces +USING: accessors assocs hashtables fry kernel make namespaces sets sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ; IN: compiler.cfg.ssa.destruction.copies @@ -9,7 +9,7 @@ ERROR: bad-copy ; : compute-copies ( assoc -- assoc' ) dup assoc-size [ '[ - [ + prune [ 2dup eq? [ 2drop ] [ _ 2dup key? [ bad-copy ] [ set-at ] if diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index c650782582..194e7e6d8f 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -29,7 +29,7 @@ SYMBOL: seen :: visit-renaming ( dst assoc src bb -- ) src seen get key? [ - src dst bb waiting-for push-at + src dst bb add-waiting src assoc delete-at ] [ src seen get conjoin ] if ; diff --git a/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor index ce2aa1c5d7..f3f4dfd2cc 100644 --- a/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor @@ -46,7 +46,7 @@ SYMBOLS: phi-union unioned-blocks ; 2nip processed-name ; :: trivial-interference ( bb src dst -- ) - dst src bb waiting-for push-at + dst src bb add-waiting src used-by-another get push ; :: add-to-renaming-set ( bb src dst -- ) diff --git a/basis/compiler/cfg/ssa/destruction/state/state.factor b/basis/compiler/cfg/ssa/destruction/state/state.factor index 30e69521b9..a10ac2c8de 100644 --- a/basis/compiler/cfg/ssa/destruction/state/state.factor +++ b/basis/compiler/cfg/ssa/destruction/state/state.factor @@ -14,3 +14,5 @@ SYMBOLS: processed-names waiting used-by-another renaming-sets ; : processed-name ( vreg -- ) processed-names get conjoin ; : waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ; + +: add-waiting ( dst src bb -- ) waiting-for push-at ; \ No newline at end of file diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index f1d17fe4a2..40f64cf4f1 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 alien.c-types ; +combinators vectors grouping make alien.c-types combinators.short-circuit ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -345,4 +345,17 @@ cell 4 = [ dup [ \ vector eq? ] [ drop f ] if over rot [ drop ] [ nip ] if ] compile-call -] unit-test \ No newline at end of file +] unit-test + +! Coalesing bug reduced from sequence-parser:take-sequence +: coalescing-bug-1 ( str a b c -- a b c d ) + 3dup { + [ 2drop 0 < ] + [ [ drop ] 2dip length > ] + [ drop > ] + } 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ; + +[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test +[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 5 "hello" coalescing-bug-1 ] unit-test +[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test +[ 2 3 T{ slice f "hello" 1 3 } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test \ No newline at end of file From 1993274d01a5f2deac54ff90a0efa46d77b1a775 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 19:46:18 -0500 Subject: [PATCH 18/25] alien.libraries: add-library should now reload the library properly, instead of just leaking DLL handles --- basis/alien/libraries/libraries.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index b2ce66b02c..0d255b8d07 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -29,5 +29,6 @@ M: library dispose dll>> [ dispose ] when* ; : remove-library ( name -- ) libraries get delete-at* [ dispose ] [ drop ] if ; -: add-library ( name path abi -- ) - swap libraries get [ delete-at ] [ set-at ] 2bi ; \ No newline at end of file +: add-library ( name path abi -- ) + [ 2drop remove-library ] + [ swap libraries get set-at ] 3bi ; \ No newline at end of file From d63f8ed6828fb85ec5813f8d2ca67a82d501486c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 19:54:11 -0500 Subject: [PATCH 19/25] alien.marshall.syntax: add C-INCLUDE: to please OpenBSD x86-64 --- extra/alien/marshall/syntax/syntax-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor index 401934e736..4d296cc402 100644 --- a/extra/alien/marshall/syntax/syntax-docs.factor +++ b/extra/alien/marshall/syntax/syntax-docs.factor @@ -18,6 +18,7 @@ HELP: CM-FUNCTION: "C-LIBRARY: exlib" "" "C-INCLUDE: " + "C-INCLUDE: " "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )" " *x = a + b;" " *y = a - b;" From 06eeedcb4cc624d418f47689766feb3b8622800f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 31 Jul 2009 21:48:17 -0500 Subject: [PATCH 20/25] change-tracking-tuple class. subclasses will have a "changed?" slot that gets set to true when any slot is modified --- core/classes/classes-docs.factor | 17 ++++++++++- core/classes/classes.factor | 3 ++ core/slots/slots.factor | 28 +++++++++++++------ .../classes/tuple/change-tracking/authors.txt | 1 + .../change-tracking-tests.factor | 10 +++++++ .../change-tracking/change-tracking.factor | 23 +++++++++++++++ .../classes/tuple/change-tracking/summary.txt | 1 + 7 files changed, 74 insertions(+), 9 deletions(-) create mode 100644 extra/classes/tuple/change-tracking/authors.txt create mode 100644 extra/classes/tuple/change-tracking/change-tracking-tests.factor create mode 100644 extra/classes/tuple/change-tracking/change-tracking.factor create mode 100644 extra/classes/tuple/change-tracking/summary.txt diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 109a3b8089..32bf483f72 100644 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -35,6 +35,7 @@ $nl "You can ask a class for its superclass:" { $subsection superclass } { $subsection superclasses } +{ $subsection subclass-of? } "Class predicates can be used to test instances directly:" { $subsection "class-predicates" } "There is a universal class which all objects are an instance of, and an empty class with no instances:" @@ -102,7 +103,21 @@ HELP: superclasses } } ; -{ superclass superclasses } related-words +HELP: subclass-of? +{ $values + { "class" class } + { "superclass" class } + { "?" boolean } +} +{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." } +{ $examples + { $example "USING: classes classes.tuple prettyprint words ;" + "tuple-class \\ class subclass-of? ." + "t" + } +} ; + +{ superclass superclasses subclass-of? } related-words HELP: members { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index dfaec95f76..f009368420 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -59,6 +59,9 @@ M: predicate reset-word : superclasses ( class -- supers ) [ superclass ] follow reverse ; +: subclass-of? ( class superclass -- ? ) + swap superclasses member? ; + : members ( class -- seq ) #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9215857018 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ drop define ] 3bi ; -: reader-quot ( slot-spec -- quot ) - [ +GENERIC# reader-quot 1 ( class slot-spec -- quot ) + +M: object reader-quot + nip [ dup offset>> , \ slot , dup class>> object bootstrap-word eq? @@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ; : define-reader ( class slot-spec -- ) [ nip name>> define-reader-generic ] [ - [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> reader-word ] + [ reader-quot ] + [ nip reader-props ] + } 2cleave define-typecheck ] 2bi ; : writer-word ( name -- word ) @@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ; : writer-quot/fixnum ( slot-spec -- ) [ [ >fixnum ] dip ] % writer-quot/check ; -: writer-quot ( slot-spec -- quot ) - [ +GENERIC# writer-quot 1 ( class slot-spec -- quot ) + +M: object writer-quot + nip [ { { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] } { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] } @@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ; : define-writer ( class slot-spec -- ) [ nip name>> define-writer-generic ] [ - [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> writer-word ] + [ writer-quot ] + [ nip writer-props ] + } 2cleave define-typecheck ] 2bi ; : setter-word ( name -- word ) diff --git a/extra/classes/tuple/change-tracking/authors.txt b/extra/classes/tuple/change-tracking/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/classes/tuple/change-tracking/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/classes/tuple/change-tracking/change-tracking-tests.factor b/extra/classes/tuple/change-tracking/change-tracking-tests.factor new file mode 100644 index 0000000000..e0289500bc --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking-tests.factor @@ -0,0 +1,10 @@ +USING: classes.tuple.change-tracking tools.test ; +IN: classes.tuple.change-tracking.tests + +TUPLE: resource < change-tracking-tuple + { pathname string } ; + +: ( pathname -- resource ) f swap resource boa ; + +[ t ] [ "foo" "bar" >>pathname changed?>> ] unit-test +[ f ] [ "foo" [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test diff --git a/extra/classes/tuple/change-tracking/change-tracking.factor b/extra/classes/tuple/change-tracking/change-tracking.factor new file mode 100644 index 0000000000..3e210922b5 --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking.factor @@ -0,0 +1,23 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes classes.tuple fry kernel sequences slots ; +IN: classes.tuple.change-tracking + +TUPLE: change-tracking-tuple + { changed? boolean } ; + +PREDICATE: change-tracking-tuple-class < tuple-class + change-tracking-tuple subclass-of? ; + +: changed? ( tuple -- changed? ) changed?>> ; inline +: clear-changed ( tuple -- tuple ) f >>changed? ; inline + +: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline + +> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; + +PRIVATE> + diff --git a/extra/classes/tuple/change-tracking/summary.txt b/extra/classes/tuple/change-tracking/summary.txt new file mode 100644 index 0000000000..3545c4b258 --- /dev/null +++ b/extra/classes/tuple/change-tracking/summary.txt @@ -0,0 +1 @@ +Tuple classes that keep track of when they've been modified From 7c43f71c6d2fd60758eff1d99f831859d9f72939 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 22:33:02 -0500 Subject: [PATCH 21/25] compiler: Oops, typos in unit tests --- basis/compiler/tests/codegen.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 40f64cf4f1..698aefd7c6 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -348,7 +348,7 @@ cell 4 = [ ] unit-test ! Coalesing bug reduced from sequence-parser:take-sequence -: coalescing-bug-1 ( str a b c -- a b c d ) +: coalescing-bug-1 ( a b c d -- a b c d ) 3dup { [ 2drop 0 < ] [ [ drop ] 2dip length > ] @@ -356,6 +356,6 @@ cell 4 = [ } 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ; [ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test -[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 5 "hello" coalescing-bug-1 ] unit-test +[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test [ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test -[ 2 3 T{ slice f "hello" 1 3 } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test \ No newline at end of file +[ 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test \ No newline at end of file From 46688f960dc784a8cfb1cb81e05db3786efebaca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 23:23:29 -0500 Subject: [PATCH 22/25] image.cpp: don't try to make code heap bigger than p->code_size since on PPC this will cause crashes if the image has a code heap of exactly 32Mb --- vm/image.cpp | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/vm/image.cpp b/vm/image.cpp index f8aa07ded9..de9de1acf1 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -53,10 +53,8 @@ cell code_relocation_base; static void load_code_heap(FILE *file, image_header *h, vm_parameters *p) { - cell good_size = h->code_size + (1 << 19); - - if(good_size > p->code_size) - p->code_size = good_size; + if(h->code_size > p->code_size) + fatal_error("Code heap too small to fit image",h->code_size); init_code_heap(p->code_size); From 61fe034e3ef9361adff884d8401ef72e506ab3f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 31 Jul 2009 23:47:07 -0500 Subject: [PATCH 23/25] cpu.ppc: put spill slots and GC roots in stack frame where subroutine calls can't clobber them --- basis/cpu/ppc/ppc.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 294de707fb..14d271c31c 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -90,14 +90,14 @@ HOOK: reserved-area-size os ( -- n ) reserved-area-size param-save-size + + ; inline : spill-integer@ ( n -- offset ) - spill-integer-offset param@ ; + spill-integer-offset local@ ; : spill-float@ ( n -- offset ) - spill-float-offset param@ ; + spill-float-offset local@ ; ! Some FP intrinsics need a temporary scratch area in the stack ! frame, 8 bytes in size. This is in the param-save area so it -! should not overlap with spill slots. +! does not overlap with spill slots. : scratch@ ( n -- offset ) stack-frame get total-size>> factor-area-size - @@ -106,7 +106,7 @@ HOOK: reserved-area-size os ( -- n ) ! GC root area : gc-root@ ( n -- offset ) - gc-root-offset param@ ; + gc-root-offset local@ ; ! Finally we have the linkage area HOOK: lr-save os ( -- n ) @@ -415,7 +415,7 @@ M:: ppc %load-gc-root ( gc-root register -- ) M:: ppc %call-gc ( gc-root-count -- ) %prepare-alien-invoke - 3 1 gc-root-base param@ ADDI + 3 1 gc-root-base local@ ADDI gc-root-count 4 LI "inline_gc" f %alien-invoke ; From 33d37613140f1bd146116f21aef7b4e813aa2e55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Aug 2009 01:25:13 -0500 Subject: [PATCH 24/25] classes.tuple.change-tracking: fix using line in tests --- .../classes/tuple/change-tracking/change-tracking-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/classes/tuple/change-tracking/change-tracking-tests.factor b/extra/classes/tuple/change-tracking/change-tracking-tests.factor index e0289500bc..633707b23e 100644 --- a/extra/classes/tuple/change-tracking/change-tracking-tests.factor +++ b/extra/classes/tuple/change-tracking/change-tracking-tests.factor @@ -1,4 +1,4 @@ -USING: classes.tuple.change-tracking tools.test ; +USING: classes.tuple.change-tracking tools.test strings accessors kernel continuations ; IN: classes.tuple.change-tracking.tests TUPLE: resource < change-tracking-tuple From 2d719534cf5f2e00aed2eb8123e596d75fc0f21c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Aug 2009 06:12:43 -0500 Subject: [PATCH 25/25] compiler.cfg.stacks: kill set now includes all locations eliminated as a result of stack height decrease; reduces number of ##replace instructions generated by 2% --- .../compiler/cfg/stacks/global/global.factor | 2 +- basis/compiler/cfg/stacks/local/local.factor | 31 ++++++++++++++----- basis/compiler/cfg/stacks/stacks.factor | 1 + 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor index 129d7e74cd..2062815787 100644 --- a/basis/compiler/cfg/stacks/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -26,7 +26,7 @@ M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union ! which are going to be overwritten. BACKWARD-ANALYSIS: kill -M: kill-analysis transfer-set drop replace-set assoc-union ; +M: kill-analysis transfer-set drop kill-set assoc-union ; ! Main word : compute-global-sets ( cfg -- cfg' ) diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index 754789042a..4d3ed36be9 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel math namespaces sets make sequences +USING: accessors assocs kernel math math.order namespaces sets make +sequences combinators fry compiler.cfg compiler.cfg.hats compiler.cfg.instructions @@ -12,14 +13,18 @@ IN: compiler.cfg.stacks.local ! Local stack analysis. We build local peek and replace sets for every basic ! block while constructing the CFG. -SYMBOLS: peek-sets replace-sets ; +SYMBOLS: peek-sets replace-sets kill-sets ; SYMBOL: locs>vregs : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; -TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; +TUPLE: current-height +{ d initial: 0 } +{ r initial: 0 } +{ emit-d initial: 0 } +{ emit-r initial: 0 } ; SYMBOLS: local-peek-set local-replace-set replace-mapping ; @@ -72,20 +77,32 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; bi ] if ; +: compute-local-kill-set ( -- assoc ) + basic-block get current-height get + [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - ] with map ] + [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - ] with map ] + [ drop local-replace-set get at ] 2tri + [ append unique dup ] dip update ; + : begin-local-analysis ( -- ) H{ } clone local-peek-set set H{ } clone local-replace-set set H{ } clone replace-mapping set - current-height get 0 >>emit-d 0 >>emit-r drop - current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; + current-height get + [ 0 >>emit-d 0 >>emit-r drop ] + [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ; : end-local-analysis ( -- ) emit-changes - local-peek-set get basic-block get peek-sets get set-at - local-replace-set get basic-block get replace-sets get set-at ; + basic-block get { + [ [ local-peek-set get ] dip peek-sets get set-at ] + [ [ local-replace-set get ] dip replace-sets get set-at ] + [ [ compute-local-kill-set ] dip kill-sets get set-at ] + } cleave ; : clone-current-height ( -- ) current-height [ clone ] change ; : peek-set ( bb -- assoc ) peek-sets get at ; : replace-set ( bb -- assoc ) replace-sets get at ; +: kill-set ( bb -- assoc ) kill-sets get at ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index 2683222fb8..1896b0a7fb 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -13,6 +13,7 @@ IN: compiler.cfg.stacks H{ } clone rs-heights set H{ } clone peek-sets set H{ } clone replace-sets set + H{ } clone kill-sets set current-height new current-height set ; : end-stack-analysis ( -- )