From b0ad7dfebc5d176c303f482d643fdccbe724ec18 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 19:58:53 -0700 Subject: [PATCH 01/36] Adding bin-packing routines in extra/math/binpack. --- extra/math/binpack/authors.txt | 1 + extra/math/binpack/binpack-docs.factor | 19 +++++++++++++++++++ extra/math/binpack/binpack-tests.factor | 11 +++++++++++ extra/math/binpack/binpack.factor | 21 +++++++++++++++++++++ extra/math/binpack/summary.txt | 1 + 5 files changed, 53 insertions(+) create mode 100644 extra/math/binpack/authors.txt create mode 100644 extra/math/binpack/binpack-docs.factor create mode 100644 extra/math/binpack/binpack-tests.factor create mode 100644 extra/math/binpack/binpack.factor create mode 100644 extra/math/binpack/summary.txt diff --git a/extra/math/binpack/authors.txt b/extra/math/binpack/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/math/binpack/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor new file mode 100644 index 0000000000..36a29c7aa1 --- /dev/null +++ b/extra/math/binpack/binpack-docs.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: help.syntax help.markup kernel assocs sequences quotations ; + +IN: math.binpack + +HELP: binpack +{ $values { "assoc" assoc } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs the (key, value) pairs into the specified number of bins, using the value as a weight." } ; + +HELP: binpack* +{ $values { "items" sequence } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs a sequence of numbers into the specified number of bins." } ; + +HELP: binpack! +{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ; + diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor new file mode 100644 index 0000000000..6f94b8ce22 --- /dev/null +++ b/extra/math/binpack/binpack-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel tools.test ; + +[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack-numbers = ] unit-test + +[ t ] [ { { 1000 } { 100 30 } { 70 40 23 } { 60 60 7 3 } } + { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack-numbers = ] unit-test + + diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor new file mode 100644 index 0000000000..6885789ee1 --- /dev/null +++ b/extra/math/binpack/binpack.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ; + +IN: math.binpack + +: (binpack) ( bins item -- ) + swap dup [ [ second ] map sum ] map swap zip sort-keys values first push ; + +: binpack ( assoc n -- bins ) + [ sort-values reverse [ length ] keep swap ] dip + [ / ceiling ] keep [ ] map + swap [ dupd (binpack) ] each ; + +: binpack* ( items n -- bins ) + [ dup zip ] dip binpack [ keys ] map ; + +: binpack! ( items quot n -- bins ) + [ dup ] 2dip [ map zip ] dip binpack [ keys ] map ; + diff --git a/extra/math/binpack/summary.txt b/extra/math/binpack/summary.txt new file mode 100644 index 0000000000..c8b91966bb --- /dev/null +++ b/extra/math/binpack/summary.txt @@ -0,0 +1 @@ +Bin-packing algorithms. From bce227c8f33215f620f11a16a2b673d17caa5226 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 20:05:08 -0700 Subject: [PATCH 02/36] math-binpack: Fix incorrect array size, and update tests. --- extra/math/binpack/binpack-tests.factor | 10 ++++++---- extra/math/binpack/binpack.factor | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor index 6f94b8ce22..d0d4630484 100644 --- a/extra/math/binpack/binpack-tests.factor +++ b/extra/math/binpack/binpack-tests.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: kernel tools.test ; +USING: kernel tools.test math.binpack ; -[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack-numbers = ] unit-test +[ t ] [ { V{ } } { } 1 binpack = ] unit-test -[ t ] [ { { 1000 } { 100 30 } { 70 40 23 } { 60 60 7 3 } } - { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack-numbers = ] unit-test +[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack* = ] unit-test + +[ t ] [ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } } + { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack* = ] unit-test diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor index 6885789ee1..f6473f2e25 100644 --- a/extra/math/binpack/binpack.factor +++ b/extra/math/binpack/binpack.factor @@ -10,7 +10,7 @@ IN: math.binpack : binpack ( assoc n -- bins ) [ sort-values reverse [ length ] keep swap ] dip - [ / ceiling ] keep [ ] map + [ / ceiling ] keep swap [ ] map swap [ dupd (binpack) ] each ; : binpack* ( items n -- bins ) From 1c76a6865a310a10035fbf8806ff4f5b27590f4d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 23:44:45 -0700 Subject: [PATCH 03/36] math-binpack: Some cleanups recommended on IRC. --- extra/math/binpack/binpack.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor index f6473f2e25..e3a009feb5 100644 --- a/extra/math/binpack/binpack.factor +++ b/extra/math/binpack/binpack.factor @@ -6,16 +6,17 @@ USING: sequences kernel arrays vectors accessors assocs sorting math math.functi IN: math.binpack : (binpack) ( bins item -- ) - swap dup [ [ second ] map sum ] map swap zip sort-keys values first push ; + [ [ values sum ] map ] keep + zip sort-keys values first push ; : binpack ( assoc n -- bins ) - [ sort-values reverse [ length ] keep swap ] dip - [ / ceiling ] keep swap [ ] map - swap [ dupd (binpack) ] each ; + [ sort-values dup length ] dip + tuck / ceiling [ ] map + tuck [ (binpack) ] curry each ; : binpack* ( items n -- bins ) [ dup zip ] dip binpack [ keys ] map ; : binpack! ( items quot n -- bins ) - [ dup ] 2dip [ map zip ] dip binpack [ keys ] map ; + [ dupd map zip ] dip binpack [ keys ] map ; From 414ddfe2138f6fc7e6c113df73e46353aa1beda0 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 2 Oct 2008 14:16:53 -0700 Subject: [PATCH 04/36] Fix typo in db-docs. --- basis/db/db-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index b0a01269ab..29a81b3621 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -218,7 +218,7 @@ ARTICLE: "db-protocol" "Low-level database protocol" { $subsection db-open } "Closing a database:" { $subsection db-close } -"Creating tatements:" +"Creating statements:" { $subsection } { $subsection } "Using statements with the database:" From 96d6db5b9d2b8f1f9c233e40e1ba79848dd2f11b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 3 Oct 2008 21:58:57 -0700 Subject: [PATCH 05/36] Fix copyright in crypto/barrett/tests. --- extra/crypto/barrett/barrett-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/crypto/barrett/barrett-tests.factor b/extra/crypto/barrett/barrett-tests.factor index 01163f730f..13dae69dce 100644 --- a/extra/crypto/barrett/barrett-tests.factor +++ b/extra/crypto/barrett/barrett-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 DoDoug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: crypto.barrett kernel math namespaces tools.test ; IN: crypto.barrett.tests From 46c3f0def1ca86400df0ce7c82f2ed6ee8ef1a49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 20:31:48 -0500 Subject: [PATCH 06/36] Remove unused error class --- basis/random/random.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index 8a69b28171..b5f8ac48b8 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -51,13 +51,12 @@ M: sequence random ( seq -- elt ) [ length random-integer ] keep nth ] if-empty ; -ERROR: negative-random n ; M: integer random ( integer -- integer' ) - { - { [ dup 0 = ] [ ] } - { [ dup 0 < ] [ neg random-integer neg ] } - [ random-integer ] - } cond ; + dup sgn { + { 0 [ ] } + { -1 [ neg random-integer neg ] } + { 1 [ random-integer ] } + } case ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From d5112a0ced6aebdde1cd76e388a1632cb352f1de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 21:30:29 -0500 Subject: [PATCH 07/36] Working on stack frame cleanup --- basis/compiler/generator/generator.factor | 7 +- .../cpu/ppc/architecture/architecture.factor | 27 ++--- basis/cpu/x86/32/32.factor | 106 ++++++++---------- basis/cpu/x86/64/64.factor | 32 +++--- .../cpu/x86/architecture/architecture.factor | 14 ++- 5 files changed, 88 insertions(+), 98 deletions(-) diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 0a9885357e..2b398eaeea 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -296,16 +296,13 @@ M: #return-recursive generate-node : return-size ( ctype -- n ) #! Amount of space we reserve for a return value. - dup large-struct? [ heap-size ] [ drop 0 ] if ; + dup large-struct? [ heap-size ] [ drop 2 cells ] if ; : alien-stack-frame ( params -- n ) alien-parameters parameter-sizes drop ; : alien-invoke-frame ( params -- n ) - #! Two cells for temporary storage, temp@ and on x86.64, - #! small struct return value unpacking - [ return>> return-size ] [ alien-stack-frame ] bi - + 2 cells + ; + [ return>> return-size ] [ alien-stack-frame ] bi + ; : set-stack-frame ( n -- ) dup [ frame-required ] when* \ stack-frame set ; diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 80ee1802e1..aab104fa6e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -44,7 +44,7 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; M: ppc stack-frame ( n -- i ) - local@ factor-area-size + 4 cells align ; + local@ factor-area-size + cell + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,11 +166,13 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: stack-params %load-param-reg ( stack reg reg-class -- ) drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ; +: next-param@ ( n -- x ) param@ stack-frame* + ; + M: stack-params %save-param-reg ( stack reg reg-class -- ) #! Funky. Read the parameter from the caller's stack frame. #! This word is used in callbacks drop - 0 1 rot param@ stack-frame* + LWZ + 0 1 rot next-param@ LWZ 0 1 rot local@ STW ; M: ppc %prepare-unbox ( -- ) @@ -197,10 +199,8 @@ M: ppc %unbox-long-long ( n func -- ) M: ppc %unbox-large-struct ( n c-type -- ) ! Value must be in r3 - ! Compute destination address - 4 1 roll local@ ADDI - ! Load struct size - heap-size 5 LI + ! Compute destination address and load struct size + [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi* ! Call the function "to_value_struct" f %alien-invoke ; @@ -218,9 +218,8 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ; - -: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; +: struct-return@ ( size n -- n ) + [ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ; M: ppc %prepare-box-struct ( size -- ) #! Compute target address for value struct return @@ -231,10 +230,8 @@ M: ppc %box-large-struct ( n c-type -- ) #! If n = f, then we're boxing a returned struct heap-size [ swap struct-return@ ] keep - ! Compute destination address - 3 1 roll ADDI - ! Load struct size - 4 LI + ! Compute destination address and load struct size + [ 3 1 rot ADDI ] [ 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; @@ -256,10 +253,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 3 1 cell temp@ STW ; + 3 11 MR ; M: ppc %alien-indirect ( -- ) - 11 1 cell temp@ LWZ (%call) ; + (%call) ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 50d8025b38..1173b9e68e 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays cpu.x86.assembler +USING: locals alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences -stack-checker.known-words -compiler.generator.registers compiler.generator.fixup -compiler.generator system layouts combinators -command-line compiler compiler.units io vocabs.loader accessors -init ; +stack-checker.known-words compiler.generator.registers +compiler.generator.fixup compiler.generator system layouts +combinators command-line compiler compiler.units io +vocabs.loader accessors init ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -18,7 +17,6 @@ IN: cpu.x86.32 M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; -M: x86.32 stack-save-reg EDX ; M: x86.32 temp-reg-1 EAX ; M: x86.32 temp-reg-2 ECX ; @@ -32,15 +30,20 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; +: struct-return@ ( size n -- operand ) + [ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ; + ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; M: int-regs param-regs drop { } ; M: int-regs vregs drop { EAX ECX EDX EBP } ; M: int-regs push-return-reg return-reg PUSH ; -: load/store-int-return ( n reg-class -- src dst ) - return-reg stack-reg rot [+] ; -M: int-regs load-return-reg load/store-int-return MOV ; -M: int-regs store-return-reg load/store-int-return swap MOV ; + +M: int-regs load-return-reg + return-reg swap next-stack@ MOV ; + +M: int-regs store-return-reg + [ stack@ ] [ return-reg ] bi* MOV ; M: float-regs param-regs drop { } ; M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; @@ -48,14 +51,16 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ; M: float-regs push-return-reg - stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ; + stack-reg swap reg-size + [ SUB ] [ [ [] ] dip FSTP ] 2bi ; : FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ; -: load/store-float-return ( n reg-class -- op size ) - [ stack@ ] [ reg-size ] bi* ; -M: float-regs load-return-reg load/store-float-return FLD ; -M: float-regs store-return-reg load/store-float-return FSTP ; +M: float-regs load-return-reg + [ next-stack@ ] [ reg-size ] bi* FLD ; + +M: float-regs store-return-reg + [ stack@ ] [ reg-size ] bi* FSTP ; : align-sub ( n -- ) dup 16 align swap - ESP swap SUB ; @@ -64,7 +69,8 @@ M: float-regs store-return-reg load/store-float-return FSTP ; 16 align ESP swap ADD ; : with-aligned-stack ( n quot -- ) - swap dup align-sub slip align-add ; inline + [ [ align-sub ] [ call ] bi* ] + [ [ align-add ] [ drop ] bi* ] 2bi ; inline M: x86.32 fixnum>slot@ 1 SHR ; @@ -77,57 +83,40 @@ M: object %load-param-reg 3drop ; M: object %save-param-reg 3drop ; -: box@ ( n reg-class -- stack@ ) - #! Used for callbacks; we want to box the values given to - #! us by the C function caller. Computes stack location of - #! nth parameter; note that we must go back one more stack - #! frame, since %box sets one up to call the one-arg boxer - #! function. The size of this stack frame so far depends on - #! the reg-class of the boxer's arg. - reg-size neg + stack-frame* + 20 + ; - : (%box) ( n reg-class -- ) #! If n is f, push the return register onto the stack; we #! are boxing a return value of a C function. If n is an #! integer, push [ESP+n] on the stack; we are boxing a #! parameter being passed to a callback from C. - over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if - push-return-reg ; + over [ load-return-reg ] [ 2drop ] if ; -M: x86.32 %box ( n reg-class func -- ) - over reg-size [ - >r (%box) r> f %alien-invoke +M:: x86.32 %box ( n reg-class func -- ) + n reg-class (%box) + reg-class reg-size [ + reg-class push-return-reg + func f %alien-invoke ] with-aligned-stack ; : (%box-long-long) ( n -- ) - #! If n is f, push the return registers onto the stack; we - #! are boxing a return value of a C function. If n is an - #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are - #! boxing a parameter being passed to a callback from C. [ - int-regs box@ - EDX over stack@ MOV - EAX swap cell - stack@ MOV - ] when* - EDX PUSH - EAX PUSH ; + EDX over next-stack@ MOV + EAX swap cell - next-stack@ MOV + ] when* ; M: x86.32 %box-long-long ( n func -- ) + [ (%box-long-long) ] dip 8 [ - [ (%box-long-long) ] [ f %alien-invoke ] bi* + EDX PUSH + EAX PUSH + f %alien-invoke ] with-aligned-stack ; -: struct-return@ ( size n -- n ) - [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ; - -M: x86.32 %box-large-struct ( n c-type -- ) +M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - heap-size - [ swap struct-return@ ] keep - ECX ESP roll [+] LEA + ECX c-type heap-size n struct-return@ LEA 8 [ ! Push struct size - PUSH + c-type heap-size PUSH ! Push destination address ECX PUSH ! Copy the struct from the C stack @@ -136,9 +125,9 @@ M: x86.32 %box-large-struct ( n c-type -- ) M: x86.32 %prepare-box-struct ( size -- ) ! Compute target address for value struct return - EAX ESP rot f struct-return@ [+] LEA + EAX swap f struct-return@ LEA ! Store it as the first parameter - ESP [] EAX MOV ; + 0 stack@ EAX MOV ; M: x86.32 %box-small-struct ( c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. @@ -207,13 +196,12 @@ M: x86 %unbox-small-struct ( size -- ) } case ; M: x86.32 %unbox-large-struct ( n c-type -- ) - #! Alien must be in EAX. - heap-size + ! Alien must be in EAX. ! Compute destination address - ECX ESP roll [+] LEA + ECX rot stack@ LEA 12 [ ! Push struct size - PUSH + heap-size PUSH ! Push destination address ECX PUSH ! Push source address @@ -224,10 +212,10 @@ M: x86.32 %unbox-large-struct ( n c-type -- ) M: x86.32 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - cell temp@ EAX MOV ; + EBP EAX MOV ; M: x86.32 %alien-indirect ( -- ) - cell temp@ CALL ; + EBP CALL ; M: x86.32 %alien-callback ( quot -- ) 4 [ @@ -239,7 +227,7 @@ M: x86.32 %alien-callback ( quot -- ) M: x86.32 %callback-value ( ctype -- ) ! Align C stack ESP 12 SUB - ! Save top of data stack + ! Save top of data stack in non-volatile register %prepare-unbox EAX PUSH ! Restore data/call/retain stacks diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 01b8935e39..8c9762630b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -12,7 +12,6 @@ IN: cpu.x86.64 M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; -M: x86.64 stack-save-reg RSI ; M: x86.64 temp-reg-1 RAX ; M: x86.64 temp-reg-2 RCX ; @@ -46,7 +45,9 @@ M: stack-params %load-param-reg r> stack@ R11 MOV ; M: stack-params %save-param-reg - >r stack-frame* + cell + swap r> %load-param-reg ; + drop + R11 swap next-stack@ MOV + stack@ R11 MOV ; : with-return-regs ( quot -- ) [ @@ -121,7 +122,7 @@ M: x86.64 %unbox-large-struct ( n c-type -- ) ! Source is in RDI heap-size ! Load destination address - RSI RSP roll [+] LEA + RSI rot stack@ LEA ! Load structure size RDX swap MOV ! Copy the struct to the C stack @@ -145,7 +146,7 @@ M: x86.64 %box-long-long ( n func -- ) M: x86.64 struct-small-enough? ( size -- ? ) heap-size 2 cells <= ; -: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ; +: box-struct-field@ ( i -- operand ) 1+ cells stack@ ; : %box-struct-field ( c-type i -- ) box-struct-field@ swap reg-class>> { @@ -164,21 +165,22 @@ M: x86.64 %box-small-struct ( c-type -- ) ] with-return-regs ; : struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if ; + [ ] [ \ stack-frame get swap - ] ?if stack@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 heap-size RSI over MOV ! Compute destination address - swap struct-return@ RDI RSP rot [+] LEA + RDI spin struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; M: x86.64 %prepare-box-struct ( size -- ) - ! Compute target address for value struct return - RAX RSP rot f struct-return@ [+] LEA - RSP 0 [+] RAX MOV ; + ! Compute target address for value struct return, store it + ! as the first parameter + RAX swap f struct-return@ LEA + 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; @@ -192,10 +194,10 @@ M: x86.64 %alien-invoke M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - cell temp@ RAX MOV ; + RBP RAX MOV ; M: x86.64 %alien-indirect ( -- ) - cell temp@ CALL ; + RBP CALL ; M: x86.64 %alien-callback ( quot -- ) RDI load-indirect "c_to_factor" f %alien-invoke ; @@ -203,12 +205,14 @@ M: x86.64 %alien-callback ( quot -- ) M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox - ! Put former top of data stack in RDI - cell temp@ RDI MOV + ! Save top of data stack + RSP 8 SUB + RDI PUSH ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Put former top of data stack in RDI - RDI cell temp@ MOV + RDI POP + RSP 8 ADD ! Unbox former top of data stack to return registers unbox-return ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index c97552a649..4770400434 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -10,10 +10,16 @@ IN: cpu.x86.architecture HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) HOOK: stack-reg cpu ( -- reg ) -HOOK: stack-save-reg cpu ( -- reg ) : stack@ ( n -- op ) stack-reg swap [+] ; +: next-stack@ ( n -- operand ) + #! nth parameter from the next stack frame. Used to box + #! input values to callbacks; the callback has its own + #! stack frame set up, and we want to read the frame + #! set up by the caller. + stack-frame* + cell + stack@ ; + : reg-stack ( n reg -- op ) swap cells neg [+] ; M: ds-loc v>operand n>> ds-reg reg-stack ; @@ -32,8 +38,8 @@ M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) -GENERIC: load-return-reg ( stack@ reg-class -- ) -GENERIC: store-return-reg ( stack@ reg-class -- ) +GENERIC: load-return-reg ( n reg-class -- ) +GENERIC: store-return-reg ( n reg-class -- ) ! Only used by inline allocation HOOK: temp-reg-1 cpu ( -- reg ) @@ -137,8 +143,6 @@ M: x86 small-enough? ( n -- ? ) : %tag-fixnum ( reg -- ) tag-bits get SHL ; -: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ; - M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics From cf135e08b382e63c43f44905492ccc1598457556 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:35 -0500 Subject: [PATCH 08/36] Tweak deploy descriptor to speed up tools.deploy test --- basis/tools/deploy/test/6/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index 410bb770be..e7d3764d39 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/basis/tools/deploy/test/6/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-threads? f } - { deploy-ui? f } - { deploy-io 1 } - { deploy-c-types? f } - { deploy-name "tools.deploy.test.6" } - { deploy-compiler? t } { deploy-reflection 1 } { deploy-word-props? f } + { deploy-io 1 } + { deploy-name "tools.deploy.test.6" } + { deploy-math? t } + { deploy-random? f } + { deploy-compiler? t } + { deploy-ui? f } + { deploy-c-types? f } { deploy-word-defs? f } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? f } + { deploy-threads? f } } From 66ae62638d74f983d923ba08daef139b64be838c Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:52 -0500 Subject: [PATCH 09/36] Fix Windows deployment --- basis/tools/deploy/shaker/shaker.factor | 2 +- basis/tools/deploy/windows/windows.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/tools/deploy/shaker/shaker.factor mode change 100644 => 100755 basis/tools/deploy/windows/windows.factor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor old mode 100644 new mode 100755 index 7c02e87209..d9348bedd5 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -321,7 +321,7 @@ IN: tools.deploy.shaker ] [ drop ] if ; : strip-c-io ( -- ) - deploy-io get 2 = [ + deploy-io get 2 = os windows? or [ [ c-io-backend forget "io.streams.c" forget-vocab diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor old mode 100644 new mode 100755 index ce4fee19d7..ad1b3cbd84 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -14,7 +14,7 @@ IN: tools.deploy.windows "resource:freetype6.dll" "resource:zlib1.dll" } swap copy-files-into - ] when ; + ] [ drop ] if ; : create-exe-dir ( vocab bundle-name -- vm ) deploy-ui? get [ From 0cfedcdc8d788064abc544eeea946b41cc8b4fde Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:08:13 -0500 Subject: [PATCH 10/36] Fix deploy size regresson --- basis/random/random-docs.factor | 22 +++++++++++----------- basis/random/random.factor | 15 +++------------ 2 files changed, 14 insertions(+), 23 deletions(-) mode change 100644 => 100755 basis/random/random-docs.factor mode change 100644 => 100755 basis/random/random.factor diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor old mode 100644 new mode 100755 index 51656a77dd..18c9ca781c --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -15,21 +15,18 @@ HELP: random-bytes* { $description "Generates a byte-array of random bytes." } ; HELP: random -{ $values { "obj" object } { "elt" "a random element" } } -{ $description "Outputs a random element of the input object. If the object is an integer, an input of zero always returns a zero, while any other integer integers yield a random integer in the interval between itself and zero, inclusive of zero. On a sequence, an empty sequence always outputs " { $link f } "." } +{ $values { "seq" sequence } { "elt" "a random element" } } +{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." } +{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." } { $examples { $unchecked-example "USING: random prettyprint ;" "10 random ." "3" } - { $example "USING: random prettyprint ;" - "0 random ." - "0" } { $unchecked-example "USING: random prettyprint ;" - "-10 random ." - "-8" } - { $unchecked-example "USING: random prettyprint ;" - "{ \"a\" \"b\" \"c\" } random ." - "\"a\"" } + "SYMBOL: heads" + "SYMBOL: tails" + "{ heads tails } random ." + "heads" } } ; HELP: random-bytes @@ -74,7 +71,10 @@ ARTICLE: "random-protocol" "Random protocol" { $subsection seed-random } ; ARTICLE: "random" "Generating random integers" -"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers. The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." +"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers." +$nl +"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." +$nl "Generate a random object:" { $subsection random } "Combinators to change the random number generator:" diff --git a/basis/random/random.factor b/basis/random/random.factor old mode 100644 new mode 100755 index b5f8ac48b8..845f8e004f --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -33,10 +33,6 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; random-generator get random-bytes* ] keep head ; -GENERIC: random ( obj -- elt ) - -: random-bits ( n -- r ) 2^ random ; - -M: sequence random ( seq -- elt ) +: random-bits ( n -- r ) 2^ random-integer ; + +: random ( seq -- elt ) [ f ] [ [ length random-integer ] keep nth ] if-empty ; -M: integer random ( integer -- integer' ) - dup sgn { - { 0 [ ] } - { -1 [ neg random-integer neg ] } - { 1 [ random-integer ] } - } case ; - : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From a5fcb006fbd58d8d0dba442a70495cc33efcc1b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 22:17:56 -0500 Subject: [PATCH 11/36] Clean up x86 stack frame code a bit more --- basis/cpu/x86/architecture/architecture.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 4770400434..ea54ef85af 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! input values to callbacks; the callback has its own #! stack frame set up, and we want to read the frame #! set up by the caller. - stack-frame* + cell + stack@ ; + stack-frame* + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -52,20 +52,18 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; M: x86 stack-frame ( n -- i ) - 3 cells + 16 align cell - ; + 3 cells + 16 align ; M: x86 %save-word-xt ( -- ) temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; -: factor-area-size ( -- n ) 4 cells ; - M: x86 %prologue ( n -- ) - dup cell + PUSH + dup PUSH temp-reg v>operand PUSH - stack-reg swap 2 cells - SUB ; + stack-reg swap 3 cells - SUB ; M: x86 %epilogue ( n -- ) - stack-reg swap ADD ; + stack-reg swap cell - ADD ; HOOK: %alien-global cpu ( symbol dll register -- ) From b0d57ead863995421f0a259294e3c53e5deed5ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 23:09:10 -0500 Subject: [PATCH 12/36] Fix unit test --- basis/random/random-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index c6d88c5525..e686dd7301 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -16,4 +16,4 @@ IN: random.tests [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test -[ 0 ] [ 0 random ] unit-test +[ f ] [ 0 random ] unit-test From 33d775890cfe24d95fc295cfe6da4399b36c25fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:00 -0500 Subject: [PATCH 13/36] More stack frame refactoring --- basis/compiler/generator/fixup/fixup.factor | 6 ++-- basis/compiler/generator/generator.factor | 31 +++++++++---------- basis/cpu/architecture/architecture.factor | 13 ++++---- .../cpu/ppc/architecture/architecture.factor | 20 ++++++------ basis/cpu/x86/32/32.factor | 16 +++++----- basis/cpu/x86/64/64.factor | 17 +++++----- .../cpu/x86/architecture/architecture.factor | 20 ++++++++---- 7 files changed, 63 insertions(+), 60 deletions(-) diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ecc88a7a5e..e8bdc561b7 100644 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -13,7 +13,7 @@ TUPLE: frame-required n ; : frame-required ( n -- ) \ frame-required boa , ; -: stack-frame-size ( code -- n ) +: compute-stack-frame-size ( code -- n ) no-stack-frame [ dup frame-required? [ n>> max ] [ drop ] if ] reduce ; @@ -37,7 +37,7 @@ M: label fixup* : if-stack-frame ( frame-size quot -- ) swap dup no-stack-frame = - [ 2drop ] [ stack-frame swap call ] if ; inline + [ 2drop ] [ stack-frame-size swap call ] if ; inline M: word fixup* { @@ -146,7 +146,7 @@ SYMBOL: literal-table : fixup ( code -- literals relocation labels code ) [ init-fixup - dup stack-frame-size swap [ fixup* ] each drop + dup compute-stack-frame-size swap [ fixup* ] each drop literal-table get >array relocation-table get >byte-array diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 2b398eaeea..22de9d3587 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -299,18 +299,17 @@ M: #return-recursive generate-node dup large-struct? [ heap-size ] [ drop 2 cells ] if ; : alien-stack-frame ( params -- n ) - alien-parameters parameter-sizes drop ; + stack-frame new + swap + [ return>> return-size >>return ] + [ alien-parameters parameter-sizes drop >>params ] bi + dup [ params>> ] [ return>> ] bi + >>size + dup size>> stack-frame-size >>total-size ; -: alien-invoke-frame ( params -- n ) - [ return>> return-size ] [ alien-stack-frame ] bi + ; - -: set-stack-frame ( n -- ) - dup [ frame-required ] when* \ stack-frame set ; - -: with-stack-frame ( n quot -- ) - swap set-stack-frame +: with-stack-frame ( params quot -- ) + swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi call - f set-stack-frame ; inline + stack-frame off ; inline GENERIC: reg-size ( register-class -- n ) @@ -413,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types ) #! parameters. If the C function is returning a structure, #! the first parameter is an implicit target area pointer, #! so we need to use a different offset. - return>> dup large-struct? - [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ; + return>> large-struct? + [ %prepare-box-struct cell ] [ 0 ] if ; : objects>registers ( params -- ) #! Generate code for unboxing a list of C types, then @@ -473,7 +472,7 @@ M: no-such-symbol compiler-error-type M: #alien-invoke generate-node params>> - dup alien-invoke-frame [ + dup [ end-basic-block %prepare-alien-invoke dup objects>registers @@ -487,7 +486,7 @@ M: #alien-invoke generate-node ! #alien-indirect M: #alien-indirect generate-node params>> - dup alien-invoke-frame [ + dup [ ! Flush registers end-basic-block ! Save registers for GC @@ -553,7 +552,7 @@ TUPLE: callback-context ; : callback-unwind ( params -- n ) { - { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] } { [ dup return>> large-struct? ] [ drop 4 ] } [ drop 0 ] } cond ; @@ -569,7 +568,7 @@ TUPLE: callback-context ; dup xt>> dup [ init-templates %prologue-later - dup alien-stack-frame [ + dup [ [ registers>objects ] [ wrap-callback-quot %alien-callback ] [ %callback-return ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 63c52d1025..f22d4a2a90 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic kernel kernel.private math memory -namespaces make sequences layouts system hashtables classes -alien byte-arrays combinators words sets ; +USING: accessors arrays generic kernel kernel.private math +memory namespaces make sequences layouts system hashtables +classes alien byte-arrays combinators words sets ; IN: cpu.architecture ! Register classes @@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- ) HOOK: load-indirect cpu ( obj reg -- ) -HOOK: stack-frame cpu ( frame-size -- n ) +HOOK: stack-frame-size cpu ( frame-size -- n ) -: stack-frame* ( -- n ) - \ stack-frame get stack-frame ; +TUPLE: stack-frame total-size size params return ; ! Set up caller stack frame HOOK: %prologue cpu ( n -- ) @@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- ) HOOK: %box-long-long cpu ( n func -- ) -HOOK: %prepare-box-struct cpu ( size -- ) +HOOK: %prepare-box-struct cpu ( -- ) HOOK: %box-small-struct cpu ( c-type -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index aab104fa6e..357349193e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -43,8 +43,8 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; -M: ppc stack-frame ( n -- i ) - local@ factor-area-size + cell + 4 cells align ; +M: ppc stack-frame-size ( n -- i ) + local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,7 +166,7 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: stack-params %load-param-reg ( stack reg reg-class -- ) drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ; -: next-param@ ( n -- x ) param@ stack-frame* + ; +: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ; M: stack-params %save-param-reg ( stack reg reg-class -- ) #! Funky. Read the parameter from the caller's stack frame. @@ -218,20 +218,18 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: struct-return@ ( size n -- n ) - [ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ; +: struct-return@ ( n -- n ) + [ stack-frame get params>> ] unless* local@ ; -M: ppc %prepare-box-struct ( size -- ) +M: ppc %prepare-box-struct ( -- ) #! Compute target address for value struct return - 3 1 rot f struct-return@ ADDI + 3 1 f struct-return@ ADDI 3 1 0 local@ STW ; M: ppc %box-large-struct ( n c-type -- ) - #! If n = f, then we're boxing a returned struct - heap-size - [ swap struct-return@ ] keep + ! If n = f, then we're boxing a returned struct ! Compute destination address and load struct size - [ 3 1 rot ADDI ] [ 4 LI ] bi* + [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 1173b9e68e..dc891a8178 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -30,8 +30,8 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; -: struct-return@ ( size n -- operand ) - [ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ; +: struct-return@ ( n -- operand ) + [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; @@ -63,10 +63,10 @@ M: float-regs store-return-reg [ stack@ ] [ reg-size ] bi* FSTP ; : align-sub ( n -- ) - dup 16 align swap - ESP swap SUB ; + [ align-stack ] keep - decr-stack-reg ; : align-add ( n -- ) - 16 align ESP swap ADD ; + align-stack incr-stack-reg ; : with-aligned-stack ( n quot -- ) [ [ align-sub ] [ call ] bi* ] @@ -113,7 +113,7 @@ M: x86.32 %box-long-long ( n func -- ) M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - ECX c-type heap-size n struct-return@ LEA + ECX n struct-return@ LEA 8 [ ! Push struct size c-type heap-size PUSH @@ -123,9 +123,9 @@ M:: x86.32 %box-large-struct ( n c-type -- ) "box_value_struct" f %alien-invoke ] with-aligned-stack ; -M: x86.32 %prepare-box-struct ( size -- ) +M: x86.32 %prepare-box-struct ( -- ) ! Compute target address for value struct return - EAX swap f struct-return@ LEA + EAX f struct-return@ LEA ! Store it as the first parameter 0 stack@ EAX MOV ; @@ -248,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- ) { { [ dup abi>> "stdcall" = ] - [ alien-stack-frame ESP swap SUB ] + [ drop ESP stack-frame get params>> SUB ] } { [ dup return>> large-struct? ] [ drop EAX PUSH ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8c9762630b..5bcd733eaa 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -164,22 +164,21 @@ M: x86.64 %box-small-struct ( c-type -- ) "box_small_struct" f %alien-invoke ] with-return-regs ; -: struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if stack@ ; +: struct-return@ ( n -- operand ) + [ stack-frame get params>> ] unless* stack@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 - heap-size - RSI over MOV + RSI swap heap-size MOV ! Compute destination address - RDI spin struct-return@ LEA + RDI swap struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; -M: x86.64 %prepare-box-struct ( size -- ) - ! Compute target address for value struct return, store it - ! as the first parameter - RAX swap f struct-return@ LEA +M: x86.64 %prepare-box-struct ( -- ) + ! Compute target address for value struct return + RAX f struct-return@ LEA + ! Store it as the first parameter 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index ea54ef85af..d10397de3b 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! input values to callbacks; the callback has its own #! stack frame set up, and we want to read the frame #! set up by the caller. - stack-frame* + stack@ ; + stack-frame get total-size>> + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -51,19 +51,27 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; -M: x86 stack-frame ( n -- i ) - 3 cells + 16 align ; +: align-stack ( n -- n' ) + os macosx? [ 16 align ] when ; + +M: x86 stack-frame-size ( n -- i ) + 3 cells + align-stack ; M: x86 %save-word-xt ( -- ) temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; +: decr-stack-reg ( n -- ) + dup 0 = [ drop ] [ stack-reg swap SUB ] if ; + M: x86 %prologue ( n -- ) dup PUSH temp-reg v>operand PUSH - stack-reg swap 3 cells - SUB ; + 3 cells - decr-stack-reg ; -M: x86 %epilogue ( n -- ) - stack-reg swap cell - ADD ; +: incr-stack-reg ( n -- ) + dup 0 = [ ] [ stack-reg swap ADD ] if ; + +M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; HOOK: %alien-global cpu ( symbol dll register -- ) From 4ca06ae50ff25eb93a5214914645eb1381393969 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:24 -0500 Subject: [PATCH 14/36] Typo --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index d10397de3b..417f90c9f9 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -69,7 +69,7 @@ M: x86 %prologue ( n -- ) 3 cells - decr-stack-reg ; : incr-stack-reg ( n -- ) - dup 0 = [ ] [ stack-reg swap ADD ] if ; + dup 0 = [ drop ] [ stack-reg swap ADD ] if ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; From 3c2caf948ae4c58a56d211597c7ab4fa9d284bd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:33:47 -0500 Subject: [PATCH 15/36] 16-align stack on x86-64 --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 417f90c9f9..01256fb4c5 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -52,7 +52,7 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; : align-stack ( n -- n' ) - os macosx? [ 16 align ] when ; + os macosx? cpu x86.64? or [ 16 align ] when ; M: x86 stack-frame-size ( n -- i ) 3 cells + align-stack ; From d142b3283772fa54998f4f4c6c709a51d45f6503 Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 6 Oct 2008 14:54:27 -0500 Subject: [PATCH 16/36] cleaner irc.messages --- extra/irc/messages/messages.factor | 168 +++++++++++++++++------------ 1 file changed, 98 insertions(+), 70 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 882cec5c8d..14c8633f6f 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -4,7 +4,6 @@ USING: kernel fry splitting ascii calendar accessors combinators qualified arrays classes.tuple math.order ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; -EXCLUDE: inverse => _ ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; @@ -17,75 +16,99 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message name ; +TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; : ( command parameters trailing -- irc-message ) - irc-message new now >>timestamp - [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + irc-message new + now >>timestamp + swap >>trailing + swap >>parameters + swap >>command ; > ( irc-message -- string ) -M: irc-message command-string>> command>> ; -M: ping command-string>> drop "PING" ; -M: join command-string>> drop "JOIN" ; -M: part command-string>> drop "PART" ; -M: quit command-string>> drop "QUIT" ; -M: nick command-string>> drop "NICK" ; -M: privmsg command-string>> drop "PRIVMSG" ; -M: notice command-string>> drop "NOTICE" ; -M: mode command-string>> drop "MODE" ; -M: kick command-string>> drop "KICK" ; +M: irc-message command-string>> ( irc-message -- string ) command>> ; +M: ping command-string>> ( ping -- string ) drop "PING" ; +M: join command-string>> ( join -- string ) drop "JOIN" ; +M: part command-string>> ( part -- string ) drop "PART" ; +M: quit command-string>> ( quit -- string ) drop "QUIT" ; +M: nick command-string>> ( nick -- string ) drop "NICK" ; +M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; +M: notice command-string>> ( notice -- string ) drop "NOTICE" ; +M: mode command-string>> ( mode -- string ) drop "MODE" ; +M: kick command-string>> ( kick -- string ) drop "KICK" ; GENERIC: command-parameters>> ( irc-message -- seq ) -M: irc-message command-parameters>> parameters>> ; -M: ping command-parameters>> drop { } ; -M: join command-parameters>> drop { } ; -M: part command-parameters>> channel>> 1array ; -M: quit command-parameters>> drop { } ; -M: nick command-parameters>> drop { } ; -M: privmsg command-parameters>> name>> 1array ; -M: notice command-parameters>> type>> 1array ; -M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ; -M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; +M: ping command-parameters>> ( ping -- seq ) drop { } ; +M: join command-parameters>> ( join -- seq ) drop { } ; +M: part command-parameters>> ( part -- seq ) channel>> 1array ; +M: quit command-parameters>> ( quit -- seq ) drop { } ; +M: nick command-parameters>> ( nick -- seq ) drop { } ; +M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; +M: notice command-parameters>> ( norice -- seq ) type>> 1array ; +M: kick command-parameters>> ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode command-parameters>> ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; -GENERIC: (>>command-parameters) ( params irc-message -- ) +GENERIC# >>command-parameters 1 ( irc-message params -- irc-message ) -M: irc-message (>>command-parameters) 2drop ; -M: logged-in (>>command-parameters) [ first ] dip (>>name) ; -M: privmsg (>>command-parameters) [ first ] dip (>>name) ; -M: notice (>>command-parameters) [ first ] dip (>>type) ; -M: part (>>command-parameters) [ first ] dip (>>channel) ; -M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ; -M: kick (>>command-parameters) - [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; -M: names-reply (>>command-parameters) - [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; -M: mode (>>command-parameters) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } - } switch ; +M: irc-message >>command-parameters ( irc-message params -- irc-message ) + drop ; + +M: logged-in >>command-parameters ( part params -- part ) + first >>name ; + +M: privmsg >>command-parameters ( privmsg params -- privmsg ) + first >>name ; + +M: notice >>command-parameters ( notice params -- notice ) + first >>type ; + +M: part >>command-parameters ( part params -- part ) + first >>channel ; + +M: kick >>command-parameters ( kick params -- kick ) + first2 [ >>channel ] [ >>who ] bi* ; + +M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use ) + second >>name ; + +M: names-reply >>command-parameters ( names-reply params -- names-reply ) + first3 nip [ >>who ] [ >>channel ] bi* ; + +M: mode >>command-parameters ( mode params -- mode ) + dup length 3 = [ + first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* + ] [ + first2 [ >>name ] [ >>mode ] bi* + ] if ; PRIVATE> GENERIC: irc-message>client-line ( irc-message -- string ) -M: irc-message irc-message>client-line +M: irc-message irc-message>client-line ( irc-message -- string ) [ command-string>> ] [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) -M: irc-message irc-message>server-line drop "not implemented yet" ; + +M: irc-message irc-message>server-line ( irc-message -- string ) + drop "not implemented yet" ; server-line drop "not implemented yet" ; : split-at-first ( seq separators -- before after ) dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ; -: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; +: remove-heading-: ( seq -- seq ) + ":" ?head drop ; : parse-name ( string -- string ) remove-heading-: "!" split-at-first drop ; : split-prefix ( string -- string/f string ) dup ":" head? - [ remove-heading-: " " split1 ] - [ f swap ] - if ; + [ remove-heading-: " " split1 ] [ f swap ] if ; : split-trailing ( string -- string string/f ) ":" split1 ; -: copy-message-in ( origin dest -- ) - { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] - [ [ line>> ] dip (>>line) ] - [ [ prefix>> ] dip (>>prefix) ] - [ [ command>> ] dip (>>command) ] - [ [ trailing>> ] dip (>>trailing) ] - [ [ timestamp>> ] dip (>>timestamp) ] - } 2cleave ; +: copy-message-in ( command irc-message -- command ) + { + [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] + [ line>> >>line ] + [ prefix>> >>prefix ] + [ command>> >>command ] + [ trailing>> >>trailing ] + [ timestamp>> >>timestamp ] + } cleave ; PRIVATE> UNION: sender-in-prefix privmsg join part quit kick mode nick ; GENERIC: irc-message-sender ( irc-message -- sender ) -M: sender-in-prefix irc-message-sender prefix>> parse-name ; +M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) + prefix>> parse-name ; : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip now irc-message boa ; +: irc-message>command ( irc-message -- command ) + [ + command>> { + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] + } case new + ] keep copy-message-in ; + : parse-irc-line ( string -- message ) - string>irc-message - dup command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] - } case new [ copy-message-in ] keep ; + string>irc-message irc-message>command ; From e42a2d8825a7a280a11610ca9910de643576654d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:01:01 -0500 Subject: [PATCH 17/36] clean up constructor --- extra/irc/client/client.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index d40c7d400d..463e35f415 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -19,9 +19,16 @@ C: irc-profile TUPLE: irc-client profile stream in-messages out-messages chats is-running nick connect reconnect-time is-ready ; + : ( profile -- irc-client ) - [ f H{ } clone f ] keep nickname>> - [ latin1 ] 15 seconds f irc-client boa ; + irc-client new + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + dup profile>> nickname>> >>nick + [ latin1 ] >>connect + 15 seconds >>reconnect-time ; TUPLE: irc-chat in-messages client ; TUPLE: irc-server-chat < irc-chat ; From 03043a7cfdba7ee943c5adadd210e3cbb83ca1e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:25:17 -0500 Subject: [PATCH 18/36] remove slot --- extra/irc/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 14c8633f6f..32533c102a 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -16,7 +16,7 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message asterisk name ; +TUPLE: nick-in-use < irc-message name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; From a0a17646c5e4f4b16be73556570336d6dfc346fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:56:54 -0500 Subject: [PATCH 19/36] dettach -> detach (spelling), fix docs --- extra/irc/client/client-docs.factor | 10 +++++----- extra/irc/client/client.factor | 2 +- extra/irc/ui/ui.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 1b9204c4f1..6d4fae9b83 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -19,8 +19,8 @@ HELP: attach-chat "Chatting with irc channels/users/etc" { $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } { $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ; -HELP: dettach-chat "Stop an unregister chat" -{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } +HELP: detach-chat "Stop an unregister chat" +{ $values { "irc-chat" "an irc chat object" } } { $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ; HELP: terminate-irc "Terminates an irc client" @@ -49,7 +49,7 @@ ARTICLE: "irc.client" "IRC Client" { $subsection connect-irc } { $subsection terminate-irc } { $subsection attach-chat } -{ $subsection dettach-chat } +{ $subsection detach-chat } { $subsection hear } { $subsection speak } { $heading "IRC messages" } @@ -72,7 +72,7 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table - { { $link irc-chat-end } "sent to a chat when it has been dettached from the client, the chat should stop after it receives this message. " } + { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " } { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } { { $link irc-disconnected } " sent to notify chats that connection was lost." } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } @@ -97,4 +97,4 @@ ARTICLE: "irc.client" "IRC Client" } ; -ABOUT: "irc.client" \ No newline at end of file +ABOUT: "irc.client" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 463e35f415..ce7a6e5373 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -362,7 +362,7 @@ PRIVATE> : attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; -: dettach-chat ( irc-chat -- ) +: detach-chat ( irc-chat -- ) [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; : speak ( message irc-chat -- ) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 50dc9378a2..e854d285b7 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -186,7 +186,7 @@ M: irc-tab graft* [ chat>> ] [ window>> client>> ] bi attach-chat ; M: irc-tab ungraft* - chat>> dettach-chat ; + chat>> detach-chat ; TUPLE: irc-channel-tab < irc-tab userlist ; From e0d6aadc8e7c8af2819907f4156f9dd7db7528fc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:14 -0500 Subject: [PATCH 20/36] complete file-info across *bsd, linux --- basis/io/unix/files/files.factor | 71 +++++++++++++++------- basis/io/unix/files/freebsd/freebsd.factor | 17 ++++++ basis/io/unix/files/freebsd/tags.txt | 1 + basis/io/unix/files/macosx/macosx.factor | 16 +++++ basis/io/unix/files/macosx/tags.txt | 1 + basis/io/unix/files/netbsd/netbsd.factor | 17 ++++++ basis/io/unix/files/netbsd/tags.txt | 1 + basis/io/unix/files/openbsd/openbsd.factor | 17 ++++++ basis/io/unix/files/openbsd/tags.txt | 1 + basis/io/unix/files/unique/unique.factor | 2 + 10 files changed, 123 insertions(+), 21 deletions(-) create mode 100644 basis/io/unix/files/freebsd/freebsd.factor create mode 100644 basis/io/unix/files/freebsd/tags.txt create mode 100644 basis/io/unix/files/macosx/macosx.factor create mode 100644 basis/io/unix/files/macosx/tags.txt create mode 100644 basis/io/unix/files/netbsd/netbsd.factor create mode 100644 basis/io/unix/files/netbsd/tags.txt create mode 100644 basis/io/unix/files/openbsd/openbsd.factor create mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index c6eda50855..4319b6c8de 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -4,7 +4,7 @@ USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private destructors ; +io.files.private destructors vocabs.loader ; IN: io.unix.files @@ -74,26 +74,14 @@ M: unix copy-file ( from to -- ) [ swap file-info permissions>> chmod io-error ] 2bi ; -: stat>type ( stat -- type ) - stat-st_mode S_IFMT bitand { - { S_IFREG [ +regular-file+ ] } - { S_IFDIR [ +directory+ ] } - { S_IFCHR [ +character-device+ ] } - { S_IFBLK [ +block-device+ ] } - { S_IFIFO [ +fifo+ ] } - { S_IFLNK [ +symbolic-link+ ] } - { S_IFSOCK [ +socket+ ] } - [ drop +unknown+ ] - } case ; +HOOK: stat>file-info os ( stat -- file-info ) -: stat>file-info ( stat -- info ) - { - [ stat>type ] - [ stat-st_size ] - [ stat-st_mode ] - [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] - } cleave - \ file-info boa ; +HOOK: stat>type os ( stat -- file-info ) + +HOOK: new-file-info os ( -- class ) + +TUPLE: unix-file-info < file-info uid gid dev ino +nlink rdev blocks blocksize ; M: unix file-info ( path -- info ) normalize-path file-status stat>file-info ; @@ -105,4 +93,45 @@ M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path read-symbolic-link ; \ No newline at end of file + normalize-path read-symbolic-link ; + +M: unix new-file-info ( -- class ) unix-file-info new ; + +M: unix stat>file-info ( stat -- file-info ) + [ new-file-info ] dip + { + [ stat>type >>type ] + [ stat-st_size >>size ] + [ stat-st_mode >>permissions ] + [ stat-st_ctim timespec>unix-time >>created ] + [ stat-st_mtim timespec>unix-time >>modified ] + [ stat-st_atim timespec>unix-time >>accessed ] + [ stat-st_uid >>uid ] + [ stat-st_gid >>gid ] + [ stat-st_dev >>dev ] + [ stat-st_ino >>ino ] + [ stat-st_nlink >>nlink ] + [ stat-st_rdev >>rdev ] + [ stat-st_blocks >>blocks ] + [ stat-st_blksize >>blocksize ] + } cleave ; + +M: unix stat>type ( stat -- type ) + stat-st_mode S_IFMT bitand { + { S_IFREG [ +regular-file+ ] } + { S_IFDIR [ +directory+ ] } + { S_IFCHR [ +character-device+ ] } + { S_IFBLK [ +block-device+ ] } + { S_IFIFO [ +fifo+ ] } + { S_IFLNK [ +symbolic-link+ ] } + { S_IFSOCK [ +socket+ ] } + [ drop +unknown+ ] + } case ; + +! Linux has no extra fields in its stat struct +os { + { macosx [ "io.unix.files.macosx" require ] } + { freebsd [ "io.unix.files.freebsd" require ] } + { netbsd [ "io.unix.files.netbsd" require ] } + { openbsd [ "io.unix.files.openbsd" require ] } +} case diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor new file mode 100644 index 0000000000..14d15bc93d --- /dev/null +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.freebsd + +TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; + +M: freebsd new-file-info ( -- class ) freebsd-file-info new ; + +M: freebsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtimepsec timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/freebsd/tags.txt b/basis/io/unix/files/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor new file mode 100644 index 0000000000..4173123e45 --- /dev/null +++ b/basis/io/unix/files/macosx/macosx.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators ; +IN: io.unix.files.macosx + +TUPLE: macosx-file-info < unix-file-info flags gen ; + +M: macosx new-file-info ( -- class ) macosx-file-info new ; + +M: macosx stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + } cleave ; diff --git a/basis/io/unix/files/macosx/tags.txt b/basis/io/unix/files/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor new file mode 100644 index 0000000000..c61304c128 --- /dev/null +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.netbsd + +TUPLE: netbsd-file-info < unix-file-info birth-time flags gen ; + +M: netbsd new-file-info ( -- class ) netbsd-file-info new ; + +M: netbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/netbsd/tags.txt b/basis/io/unix/files/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor new file mode 100644 index 0000000000..e1473eed4d --- /dev/null +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.openbsd + +TUPLE: openbsd-file-info < unix-file-info birth-time flags gen ; + +M: openbsd new-file-info ( -- class ) openbsd-file-info new ; + +M: openbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/openbsd/tags.txt b/basis/io/unix/files/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index 95e321fd93..e47ac6a2e3 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel io.ports io.unix.backend math.bitwise unix io.files.unique.backend system ; IN: io.unix.files.unique From b168d75a46747ccc64f45dc18ee02b0f6d6c1825 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:49 -0500 Subject: [PATCH 21/36] add timespec>timestamp word --- basis/calendar/calendar.factor | 9 ++++++++- basis/structs/structs.factor | 10 ++++++++++ basis/unix/time/time.factor | 12 ------------ 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 31c835aada..8a27a46aa2 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -402,9 +402,16 @@ PRIVATE> : time-since-midnight ( timestamp -- duration ) dup midnight time- ; +: since-1970 ( time -- timestamp ) + unix-1970 time+ >local-time ; + : timeval>unix-time ( timeval -- timestamp ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ unix-1970 time+ >local-time ; + time+ since-1970 ; + +: timespec>unix-time ( timeval -- timestamp ) + [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi + time+ since-1970 ; M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index f54917dc47..51ac517af3 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -10,3 +10,13 @@ C-STRUCT: timeval "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 4fbb20dca0..26b42ddfe7 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax alien.c-types math ; - IN: unix.time TYPEDEF: uint time_t @@ -18,16 +16,6 @@ C-STRUCT: tm { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) { "char*" "zone" } ; -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; - FUNCTION: time_t time ( time_t* t ) ; FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ; From 9459eaab4b81c1a9f060393c2cef594b72873523 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:11 -0500 Subject: [PATCH 22/36] all platforms support the file-info structure --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1634b7a3f1..bc84aa5d21 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,7 @@ PRIVATE> "." last-split1 nip ; ! File info -TUPLE: file-info type size permissions modified ; +TUPLE: file-info type size permissions created modified accessed ; HOOK: file-info io-backend ( path -- info ) From 0294308c4c40e3ed49f446b1e45e5e1370bd008e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:42 -0500 Subject: [PATCH 23/36] work on windows file-info --- basis/io/windows/files/files.factor | 41 ++++++++++++++++++----------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 40e7e17402..f4bb3c71dc 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -147,18 +147,18 @@ SYMBOLS: +read-only+ +hidden+ +system+ FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) + [ file-info new ] dip { - [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] [ [ WIN32_FIND_DATA-nFileSizeLow ] - [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size ] - [ WIN32_FIND_DATA-dwFileAttributes ] - ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] - [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] - ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ] - } cleave - \ file-info boa ; + [ WIN32_FIND_DATA-dwFileAttributes >>mode ] + [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ] + [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ] + } cleave ; : find-first-file-stat ( path -- WIN32_FIND_DATA ) "WIN32_FIND_DATA" [ @@ -168,23 +168,32 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] keep ; : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) + [ file-info new ] dip { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] [ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] - [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>mode ] + [ + BY_HANDLE_FILE_INFORMATION-ftCreationTime + FILETIME>timestamp >>created + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp >>modified + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastAccessTime + FILETIME>timestamp >>accessed ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] - ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] - [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] - ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] ! [ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit ! ] - } cleave - \ file-info boa ; + } cleave ; : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) [ From 847205432fe1d234f028aa6f2527d8713f17c4de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:34:58 -0500 Subject: [PATCH 24/36] fix load error --- basis/structs/structs.factor | 2 +- basis/unix/time/time.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index 51ac517af3..6aef757eb4 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -1,4 +1,4 @@ -USING: alien.c-types alien.syntax kernel math ; +USING: alien.c-types alien.syntax kernel math unix.types ; IN: structs C-STRUCT: timeval diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 26b42ddfe7..67611ae193 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,8 +1,8 @@ -USING: kernel alien.syntax alien.c-types math ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax alien.c-types math unix.types ; IN: unix.time -TYPEDEF: uint time_t - C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 From 15f15d4553083bb06909c97e16eeac906849357a Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 9 Oct 2008 13:23:43 -0700 Subject: [PATCH 25/36] Adding strftime library. --- extra/time/authors.txt | 1 + extra/time/time-docs.factor | 43 ++++++++++++++++++++++++ extra/time/time-tests.factor | 24 ++++++++++++++ extra/time/time.factor | 63 ++++++++++++++++++++++++++++++++++++ 4 files changed, 131 insertions(+) create mode 100644 extra/time/authors.txt create mode 100644 extra/time/time-docs.factor create mode 100644 extra/time/time-tests.factor create mode 100644 extra/time/time.factor diff --git a/extra/time/authors.txt b/extra/time/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/time/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor new file mode 100644 index 0000000000..b0ca12e9c6 --- /dev/null +++ b/extra/time/time-docs.factor @@ -0,0 +1,43 @@ + +USING: help.syntax help.markup kernel prettyprint sequences strings ; + +IN: time + +HELP: strftime +{ $values { "format-string" string } } +{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." } +; + +ARTICLE: "strftime" "Formatted timestamps" +"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n" +{ $subsection strftime } +"\n" +"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n" +{ $table + { "%a" "Abbreviated weekday name." } + { "%A" "Full weekday name." } + { "%b" "Abbreviated month name." } + { "%B" "Full month name." } + { "%c" "Date and time representation." } + { "%d" "Day of the month as a decimal number [01,31]." } + { "%H" "Hour (24-hour clock) as a decimal number [00,23]." } + { "%I" "Hour (12-hour clock) as a decimal number [01,12]." } + { "%j" "Day of the year as a decimal number [001,366]." } + { "%m" "Month as a decimal number [01,12]." } + { "%M" "Minute as a decimal number [00,59]." } + { "%p" "Either AM or PM." } + { "%S" "Second as a decimal number [00,59]." } + { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal numberb [00,53]." } + { "%w" "Weekday as a decimal number [0(Sunday),6]." } + { "%W" "Week number of the year (Monday as the first day of the week) as a decimal numberb [00,53]." } + { "%x" "Date representation." } + { "%X" "Time representation." } + { "%y" "Year without century as a decimal number [00,99]." } + { "%Y" "Year with century as a decimal number." } + { "%Z" "Time zone name (no characters if no time zone exists)." } + { "%%" "A literal '%' character." } +} ; + +ABOUT: "strftime" + + diff --git a/extra/time/time-tests.factor b/extra/time/time-tests.factor new file mode 100644 index 0000000000..0b0602bd62 --- /dev/null +++ b/extra/time/time-tests.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel time tools.test calendar ; + +IN: time.tests + +[ "%H:%M:%S" strftime ] must-infer + +: testtime ( -- timestamp ) + 2008 10 9 12 3 15 instant ; + +[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test +[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test + +[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test +[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test + +[ t ] [ "Thu" testtime "%a" strftime = ] unit-test +[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test + +[ t ] [ "Oct" testtime "%b" strftime = ] unit-test +[ t ] [ "October" testtime "%B" strftime = ] unit-test + diff --git a/extra/time/time.factor b/extra/time/time.factor new file mode 100644 index 0000000000..e609bf381b --- /dev/null +++ b/extra/time/time.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors arrays calendar io kernel fry macros math +math.functions math.parser peg.ebnf sequences strings vectors ; + +IN: time + +: timestring ( timestamp -- string ) + [ hour>> ] keep [ minute>> ] keep second>> 3array + [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline + +: datestring ( timestamp -- string ) + [ month>> ] keep [ day>> ] keep year>> 3array + [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline + + [[ [ "%" ] ]] +fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]] +fmt-A = "A" => [[ [ dup day-of-week day-name ] ]] +fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]] +fmt-B = "B" => [[ [ dup month>> month-name ] ]] +fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]] +fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]] +fmt-j = "j" => [[ [ dup day-of-year number>string ] ]] +fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]] +fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]] +fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] +fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] +fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] +fmt-x = "x" => [[ [ dup datestring ] ]] +fmt-X = "X" => [[ [ dup timestring ] ]] +fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] +fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] +fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] +unknown = (.)* => [[ "Unknown directive" throw ]] + +formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I| + fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x| + fmt-X|fmt-y|fmt-Y|fmt-Z|unknown + +formats = "%" (formats_) => [[ second '[ _ dip ] ]] + +plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] + +text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]] + +;EBNF + +PRIVATE> + +MACRO: strftime ( format-string -- ) + parse-format-string [ length ] keep [ ] join + '[ _ @ reverse concat nip ] ; + + From 6d2ade1173da8e7a65d0cf431d1893296f10c98b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 9 Oct 2008 19:48:05 -0700 Subject: [PATCH 26/36] Adding week-of-year words. --- extra/time/time.factor | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/time/time.factor b/extra/time/time.factor index e609bf381b..d0411bd5bf 100644 --- a/extra/time/time.factor +++ b/extra/time/time.factor @@ -6,14 +6,23 @@ math.functions math.parser peg.ebnf sequences strings vectors ; IN: time -: timestring ( timestamp -- string ) +: >timestring ( timestamp -- string ) [ hour>> ] keep [ minute>> ] keep second>> 3array [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline -: datestring ( timestamp -- string ) +: >datestring ( timestamp -- string ) [ month>> ] keep [ day>> ] keep year>> 3array [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline +: week-of-year-sunday ( timestamp -- n ) + dup clone 1 >>month 1 >>day day-of-week dup 0 > [ 7 swap - ] when + [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; + +: week-of-year-monday ( timestamp -- n ) + dup clone 1 >>month 1 >>day day-of-week dup 1 > [ 7 swap - ] when + [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; + + [[ [ dup second>> round number>string 2 CHAR fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] -fmt-x = "x" => [[ [ dup datestring ] ]] -fmt-X = "X" => [[ [ dup timestring ] ]] +fmt-x = "x" => [[ [ dup >datestring ] ]] +fmt-X = "X" => [[ [ dup >timestring ] ]] fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] From e9a36ebda33d2d55659f7e7d328821a337e9b788 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 13 Oct 2008 06:19:21 -0700 Subject: [PATCH 27/36] strftime: Some fixes to support week-of-year. --- extra/time/time-docs.factor | 4 ++-- extra/time/time.factor | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor index b0ca12e9c6..8fbc59e315 100644 --- a/extra/time/time-docs.factor +++ b/extra/time/time-docs.factor @@ -27,9 +27,9 @@ ARTICLE: "strftime" "Formatted timestamps" { "%M" "Minute as a decimal number [00,59]." } { "%p" "Either AM or PM." } { "%S" "Second as a decimal number [00,59]." } - { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal numberb [00,53]." } + { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." } { "%w" "Weekday as a decimal number [0(Sunday),6]." } - { "%W" "Week number of the year (Monday as the first day of the week) as a decimal numberb [00,53]." } + { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." } { "%x" "Date representation." } { "%X" "Time representation." } { "%y" "Year without century as a decimal number [00,99]." } diff --git a/extra/time/time.factor b/extra/time/time.factor index d0411bd5bf..be19fb0919 100644 --- a/extra/time/time.factor +++ b/extra/time/time.factor @@ -14,13 +14,13 @@ IN: time [ month>> ] keep [ day>> ] keep year>> 3array [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline -: week-of-year-sunday ( timestamp -- n ) - dup clone 1 >>month 1 >>day day-of-week dup 0 > [ 7 swap - ] when +: (week-of-year) ( timestamp day -- n ) + [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; -: week-of-year-monday ( timestamp -- n ) - dup clone 1 >>month 1 >>day day-of-week dup 1 > [ 7 swap - ] when - [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; +: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline + +: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline [[ [ dup month>> number>string 2 CHAR: 0 pad fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]] fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]] fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]] -fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] +fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]] fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] -fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] +fmt-W = "W" => [[ [ dup week-of-year-monday ] ]] fmt-x = "x" => [[ [ dup >datestring ] ]] fmt-X = "X" => [[ [ dup >timestring ] ]] fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] From faa6989fe9cbc559cd6cd2d3c7e97dcdf24f74c0 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 9 Dec 2008 02:36:55 +0100 Subject: [PATCH 28/36] FUEL: First stab at the debugger: error/restart display and restart invokation. --- extra/fuel/fuel.factor | 118 ++++++++++++------ misc/fuel/README | 17 ++- misc/fuel/factor-mode.el | 17 +++ misc/fuel/fuel-debug.el | 234 ++++++++++++++++++++++++++++++++++++ misc/fuel/fuel-eval.el | 56 +++++++-- misc/fuel/fuel-font-lock.el | 33 ++--- misc/fuel/fuel-help.el | 7 +- misc/fuel/fuel-listener.el | 49 +++++--- misc/fuel/fuel-mode.el | 49 ++++++-- 9 files changed, 472 insertions(+), 108 deletions(-) create mode 100644 misc/fuel/fuel-debug.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index d8a363ca71..acaccf5b78 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,50 +1,70 @@ ! Copyright (C) 2008 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple compiler.units continuations debugger -definitions eval io io.files io.streams.string kernel listener listener.private -make math namespaces parser prettyprint quotations sequences strings -vectors vocabs.loader ; +USING: accessors arrays classes classes.tuple compiler.units +combinators continuations debugger definitions eval help +io io.files io.streams.string kernel lexer listener listener.private +make math namespaces parser prettyprint prettyprint.config +quotations sequences strings source-files vectors vocabs.loader ; IN: fuel -! > in set ] - [ use>> clone use set ] - [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri - ] unless ; - SYMBOL: fuel-eval-result f clone fuel-eval-result set-global SYMBOL: fuel-eval-output f clone fuel-eval-result set-global -! PRIVATE> +SYMBOL: fuel-eval-res-flag +t clone fuel-eval-res-flag set-global + +: fuel-eval-restartable? ( -- ? ) + fuel-eval-res-flag get-global ; inline + +: fuel-eval-restartable ( -- ) + t fuel-eval-res-flag set-global ; inline + +: fuel-eval-non-restartable ( -- ) + f fuel-eval-res-flag set-global ; inline + +: push-fuel-status ( -- ) + in get use get clone display-stacks? get restarts get-global clone + fuel-status boa + fuel-status-stack get push ; + +: pop-fuel-status ( -- ) + fuel-status-stack get empty? [ + fuel-status-stack get pop { + [ in>> in set ] + [ use>> clone use set ] + [ ds?>> display-stacks? swap [ on ] [ off ] if ] + [ + restarts>> fuel-eval-restartable? [ drop ] [ + clone restarts set-global + ] if + ] + } cleave + ] unless ; + + +! Lispy pretty printing GENERIC: fuel-pprint ( obj -- ) -M: object fuel-pprint pprint ; +M: object fuel-pprint pprint ; inline -M: f fuel-pprint drop "nil" write ; +M: f fuel-pprint drop "nil" write ; inline -M: integer fuel-pprint pprint ; +M: integer fuel-pprint pprint ; inline -M: string fuel-pprint pprint ; +M: string fuel-pprint pprint ; inline M: sequence fuel-pprint dup empty? [ drop f fuel-pprint ] [ @@ -53,12 +73,30 @@ M: sequence fuel-pprint ")" write ] if ; -M: tuple fuel-pprint tuple>array fuel-pprint ; +M: tuple fuel-pprint tuple>array fuel-pprint ; inline -M: continuation fuel-pprint drop "~continuation~" write ; +M: continuation fuel-pprint drop ":continuation" write ; inline + +M: restart fuel-pprint name>> fuel-pprint ; inline + +SYMBOL: :restarts + +: fuel-restarts ( obj -- seq ) + compute-restarts :restarts prefix ; inline + +M: condition fuel-pprint + [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ; + +M: source-file-error fuel-pprint + [ file>> ] [ error>> ] bi 2array source-file-error prefix + fuel-pprint ; + +M: source-file fuel-pprint path>> fuel-pprint ; + +! Evaluation vocabulary : fuel-eval-set-result ( obj -- ) - clone fuel-eval-result set-global ; + clone fuel-eval-result set-global ; inline : fuel-retort ( -- ) error get @@ -67,7 +105,7 @@ M: continuation fuel-pprint drop "~continuation~" write ; 3array fuel-pprint ; : fuel-forget-error ( -- ) - f error set-global ; + f error set-global ; inline : (fuel-begin-eval) ( -- ) push-fuel-status @@ -76,23 +114,25 @@ M: continuation fuel-pprint drop "~continuation~" write ; f fuel-eval-result set-global f fuel-eval-output set-global ; +: fuel-run-with-output ( quot -- ) + with-string-writer fuel-eval-output set-global ; inline + : (fuel-end-eval) ( quot -- ) - with-string-writer fuel-eval-output set-global - fuel-retort - pop-fuel-status ; + fuel-run-with-output fuel-retort pop-fuel-status ; inline : (fuel-eval) ( lines -- ) - [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ; + [ [ parse-lines ] with-compilation-unit call ] curry + [ print-error ] recover ; inline : (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; + [ 1vector (fuel-eval) ] each ; inline : (fuel-eval-usings) ( usings -- ) [ "USING: " prepend " ;" append ] map (fuel-eval-each) fuel-forget-error ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; + [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline : fuel-eval-in-context ( lines in usings -- ) (fuel-begin-eval) [ @@ -107,15 +147,15 @@ M: continuation fuel-pprint drop "~continuation~" write ; fuel-retort ; : fuel-eval ( lines -- ) - (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; + (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline -: fuel-end-eval ( -- ) - [ ] (fuel-end-eval) ; +: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline : fuel-get-edit-location ( defspec -- ) where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; -: fuel-startup ( -- ) - "listener" run ; +: fuel-run-file ( path -- ) run-file ; inline + +: fuel-startup ( -- ) "listener" run ; inline MAIN: fuel-startup diff --git a/misc/fuel/README b/misc/fuel/README index 078490abfd..18f6fa1e94 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -47,18 +47,29 @@ M-x customize-group fuel will show you how many. Quick key reference ------------------- +(Chords ending in a single letter accept also C- (e.g. C-cC-z is +the same as C-cz)). + +* In factor files: + - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files - - M-. : edit word at point in Emacs + - M-. : edit word at point in Emacs (also in listener) - C-cr, C-cC-er : eval region - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - C-M-x, C-cC-ex : eval definition around point + - C-ck, C-cC-ek : compile file - C-cC-da : toggle autodoc mode - C-cC-dd : help for word at point - C-cC-ds : short help word at point -Chords ending in a single letter accept also C- (e.g. C-cC-z is -the same as C-cz). +* In the debugger (it pops up upon eval/compilation errors): + + - g : go to error + - : invoke nth restart + - q : bury buffer + + diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index d79930bb22..b3952074f5 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -59,6 +59,23 @@ code in the buffer." :type 'hook :group 'factor-mode) + +;;; Faces: + +(fuel-font-lock--define-faces + factor-font-lock font-lock factor-mode + ((comment comment "comments") + (constructor type "constructors ()") + (declaration keyword "declaration words") + (parsing-word keyword "parsing words") + (setter-word function-name "setter words (>>foo)") + (stack-effect comment "stack effect specifications") + (string string "strings") + (symbol variable-name "name of symbol being defined") + (type-name type "type names") + (vocabulary-name constant "vocabulary names") + (word function-name "word, generic or method being defined"))) + ;;; Syntax table: diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el new file mode 100644 index 0000000000..1b68f6e79f --- /dev/null +++ b/misc/fuel/fuel-debug.el @@ -0,0 +1,234 @@ +;;; fuel-debug.el -- debugging factor code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sun Dec 07, 2008 04:16 + +;;; Comentary: + +;; A mode for displaying the results of run-file and evaluation, with +;; support for restarts. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-eval) +(require 'fuel-font-lock) + + +;;; Customization: + +(defgroup fuel-debug nil + "Major mode for interaction with the Factor debugger" + :group 'fuel) + +(defcustom fuel-debug-mode-hook nil + "Hook run after `fuel-debug-mode' activates" + :group 'fuel-debug + :type 'hook) + +(defcustom fuel-debug-show-short-help t + "Whether to show short help on available keys in debugger" + :group 'fuel-debug + :type 'boolean) + +(fuel-font-lock--define-faces + fuel-debug-font-lock font-lock fuel-debug + ((error warning "highlighting errors") + (line variable-name "line numbers in errors/warnings") + (column variable-name "column numbers in errors/warnings") + (info comment "information headers") + (restart-number warning "restart numbers") + (restart-name function-name "restart names"))) + + +;;; Compilation results buffer: + +(defvar fuel-debug--buffer nil) + +(make-variable-buffer-local + (defvar fuel-debug--last-ret nil)) + +(make-variable-buffer-local + (defvar fuel-debug--file nil)) + +(defun fuel-debug--buffer () + (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer) + (with-current-buffer + (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*")) + (fuel-debug-mode) + (current-buffer)))) + +(defun fuel-debug--display-retort (ret &optional success-msg no-pop file) + (let ((err (fuel-eval--retort-error ret)) + (inhibit-read-only t)) + (with-current-buffer (fuel-debug--buffer) + (erase-buffer) + (when err (insert (format "Error: %S\n\n" (fuel-eval--error-name err)))) + (fuel-debug--display-output-1 ret) + (when (and (not err) success-msg) + (message "%s" success-msg) + (insert "\n" success-msg "\n")) + (when err + (fuel-debug--display-restarts err) + (let ((hstr (fuel-debug--help-string err))) + (if fuel-debug-show-short-help + (insert "-----------\n" hstr "\n") + (message "%s" hstr)))) + (setq fuel-debug--last-ret ret) + (setq fuel-debug--file file) + (goto-char (point-max))) + (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)))) + +(defun fuel-debug--display-output-1 (ret) + (let* ((last (fuel-eval--retort-output fuel-debug--last-ret)) + (current (fuel-eval--retort-output ret)) + (llen (length last)) + (clen (length current)) + (trail (and last (substring-no-properties last (/ llen 2)))) + (p (point))) + (save-excursion (insert current)) + (when (and (> clen llen) (> llen 0) (search-forward trail nil t)) + (delete-region p (point))) + (goto-char (point-max)))) + +(defun fuel-debug--display-restarts (err) + (let* ((rs (fuel-eval--error-restarts err)) + (rsn (length rs))) + (when rs + (insert "\n\nRestarts:\n\n") + (dotimes (n rsn) + (insert (format ":%s %s\n" (1+ n) (nth n rs)))) + (newline)))) + +(defun fuel-debug--help-string (err) + (format "Press %s%s 'q' to bury buffer" + (if (fuel-eval--error-file err) "g to visit file, " "") + (let ((rsn (length (fuel-eval--error-restarts err)))) + (cond ((zerop rsn) "") + ((= 1 rsn) "1 to invoke restart, ") + (t (format "1-%s to invoke restarts, " rsn)))))) + +(defun fuel-debug--buffer-file () + (with-current-buffer (fuel-debug--buffer) + (or fuel-debug--file + (and fuel-debug--last-ret + (fuel-eval--error-file + (fuel-eval--retort-error fuel-debug--last-ret)))))) + +(defsubst fuel-debug--buffer-error () + (fuel-eval--retort-error fuel-debug--last-ret)) + +(defsubst fuel-debug--buffer-restarts () + (fuel-eval--error-restarts (fuel-debug--buffer-error))) + + +;;; Font lock and other pattern matching: + +(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") +(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") +(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") + +(defconst fuel-debug--error-regex + (format "%s\n%s" + fuel-debug--error-file-regex + fuel-debug--error-line-regex)) + +(defconst fuel-debug--named-restart-regex + (format "^\\(%s\\) " (regexp-opt '(":warnings" ":errors" ":linkage")))) + +(defconst fuel-debug--restart-regex + "^:\\([0-9]+\\) \\(.+\\)") + +(defconst fuel-debug--font-lock-keywords + `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) + (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) + (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) + (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) + (2 'fuel-debug-font-lock-restart-name)) + (,fuel-debug--named-restart-regex 1 'fuel-debug-font-lock-restart-number) + ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) + ("^Error: " . 'fuel-debug-font-lock-error))) + +(defun fuel-debug--font-lock-setup () + (set (make-local-variable 'font-lock-defaults) + '(fuel-debug--font-lock-keywords t nil nil nil))) + +;;; Buffer navigation: + +(defun fuel-debug-goto-error () + (interactive) + (let* ((err (or (fuel-debug--buffer-error) + (error "No errors reported"))) + (file (or (fuel-eval--error-file err) + (error "No file associated with error"))) + (l/c (fuel-eval--error-line/column err)) + (line (or (car l/c) 1)) + (col (or (cdr l/c) 0))) + (find-file-other-window file) + (goto-line line) + (forward-char col))) + +(defun fuel-debug--read-restart-no () + (let ((rs (fuel-debug--buffer-restarts))) + (unless rs (error "No restarts available")) + (let* ((rsn (length rs)) + (prompt (format "Restart number? (1-%s): " rsn)) + (no 0)) + (while (or (> (setq no (read-number prompt)) rsn) + (< no 1))) + no))) + +(defun fuel-debug-exec-restart (&optional n confirm) + (interactive (list (fuel-debug--read-restart-no))) + (let ((n (or n 1)) + (rs (fuel-debug--buffer-restarts))) + (when (zerop (length rs)) + (error "No restarts available")) + (when (or (< n 1) (> n (length rs))) + (error "Restart %s not available" n)) + (when (or (not confirm) + (y-or-n-p (format "Invoke restart %s? " n))) + (message "Invoking restart %s" n) + (let* ((file (fuel-debug--buffer-file)) + (buffer (if file (find-file-noselect file) (current-buffer)))) + (with-current-buffer buffer + (fuel-debug--display-retort + (fuel-eval--eval-string/context (format ":%s" n)) + (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) + + +;;; Fuel Debug mode: + +(defvar fuel-debug-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map "g" 'fuel-debug-goto-error) + (define-key map "\C-c\C-c" 'fuel-debug-goto-error) + (define-key map "q" 'bury-buffer) + (dotimes (n 9) + (define-key map (vector (+ ?1 n)) + `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t)))) + map)) + +(defun fuel-debug-mode () + "A major mode for displaying Factor's compilation results and +invoking restarts as needed. +\\{fuel-debug-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'factor-mode) + (setq mode-name "Fuel Debug") + (use-local-map fuel-debug-mode-map) + (fuel-debug--font-lock-setup) + (setq fuel-debug--file nil) + (setq fuel-debug--last-ret nil) + (toggle-read-only 1) + (run-hooks 'fuel-debug-mode-hook)) + + +(provide 'fuel-debug) +;;; fuel-debug.el ends here diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index bef7171f6f..62001cc48c 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -38,7 +38,8 @@ (when (and (> fuel-eval-log-max-length 0) (> (point) fuel-eval-log-max-length)) (erase-buffer)) - (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n")) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256))) + (newline) (let ((beg (point))) (comint-redirect-send-command-to-process str (current-buffer) proc nil t) (with-current-buffer (process-buffer proc) @@ -58,8 +59,6 @@ (defsubst fuel-eval--retort-p (ret) (listp ret)) -(defsubst fuel-eval--error-name (err) (car err)) - (defsubst fuel-eval--make-parse-error-retort (str) (fuel-eval--retort-make 'parse-retort-error nil str)) @@ -83,29 +82,60 @@ (defsubst fuel-eval--factor-array (strs) (format "V{ %S }" (mapconcat 'identity strs " "))) -(defsubst fuel-eval--eval-strings (strs) - (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) +(defsubst fuel-eval--eval-strings (strs &optional no-restart) + (let ((str (format "fuel-eval-%s %s fuel-eval" + (if no-restart "non-restartable" "restartable") + (fuel-eval--factor-array strs)))) (fuel-eval--send/retort str))) -(defsubst fuel-eval--eval-string (str) - (fuel-eval--eval-strings (list str))) +(defsubst fuel-eval--eval-string (str &optional no-restart) + (fuel-eval--eval-strings (list str) no-restart)) -(defun fuel-eval--eval-strings/context (strs) +(defun fuel-eval--eval-strings/context (strs &optional no-restart) (let ((usings (fuel-syntax--usings-update))) (fuel-eval--send/retort - (format "%s %S %s fuel-eval-in-context" + (format "fuel-eval-%s %s %S %s fuel-eval-in-context" + (if no-restart "non-restartable" "restartable") (fuel-eval--factor-array strs) (or fuel-syntax--current-vocab "f") (if usings (fuel-eval--factor-array usings) "f"))))) -(defsubst fuel-eval--eval-string/context (str) - (fuel-eval--eval-strings/context (list str))) +(defsubst fuel-eval--eval-string/context (str &optional no-restart) + (fuel-eval--eval-strings/context (list str) no-restart)) -(defun fuel-eval--eval-region/context (begin end) +(defun fuel-eval--eval-region/context (begin end &optional no-restart) (let ((lines (split-string (buffer-substring-no-properties begin end) "[\f\n\r\v]+" t))) (when (> (length lines) 0) - (fuel-eval--eval-strings/context lines)))) + (fuel-eval--eval-strings/context lines no-restart)))) + + +;;; Error parsing + +(defsubst fuel-eval--error-name (err) (car err)) + +(defsubst fuel-eval--error-restarts (err) + (cdr (assoc :restarts (fuel-eval--error-name-p err 'condition)))) + +(defun fuel-eval--error-name-p (err name) + (unless (null err) + (or (and (eq (fuel-eval--error-name err) name) err) + (assoc name err)))) + +(defsubst fuel-eval--error-file (err) + (nth 1 (fuel-eval--error-name-p err 'source-file-error))) + +(defsubst fuel-eval--error-lexer-p (err) + (or (fuel-eval--error-name-p err 'lexer-error) + (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error) + 'lexer-error))) + +(defsubst fuel-eval--error-line/column (err) + (let ((err (fuel-eval--error-lexer-p err))) + (cons (nth 1 err) (nth 2 err)))) + +(defsubst fuel-eval--error-line-text (err) + (nth 3 (fuel-eval--error-lexer-p err))) (provide 'fuel-eval) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index c8673f742b..4c710635ba 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -21,30 +21,23 @@ ;;; Faces: -(defmacro fuel-font-lock--face (face def doc) - (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) - (def (intern (format "font-lock-%s-face" (symbol-name def))))) +(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc) + (let ((face (intern (format "%s-%s" prefix face))) + (def (intern (format "%s-%s-face" def-prefix def)))) `(defface ,face (face-default-spec ,def) ,(format "Face for %s." doc) - :group 'factor-mode + :group ',group :group 'faces))) -(defmacro fuel-font-lock--faces-setup () - (cons 'progn - (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) - '((comment comment "comments") - (constructor type "constructors ()") - (declaration keyword "declaration words") - (parsing-word keyword "parsing words") - (setter-word function-name "setter words (>>foo)") - (stack-effect comment "stack effect specifications") - (string string "strings") - (symbol variable-name "name of symbol being defined") - (type-name type "type names") - (vocabulary-name constant "vocabulary names") - (word function-name "word, generic or method being defined"))))) - -(fuel-font-lock--faces-setup) +(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces) + (let ((setup (make-symbol (format "%s--faces-setup" prefix)))) + `(progn + (defmacro ,setup () + (cons 'progn + (mapcar (lambda (f) (append '(fuel-font-lock--make-face + ,prefix ,def-prefix ,group) f)) + ',faces))) + (,setup)))) ;;; Font lock: diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index dcf17d2716..1db9b25d69 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -68,10 +68,11 @@ (defun fuel-help--word-synopsis (&optional word) (let ((word (or word (fuel-syntax-symbol-at-point))) - (fuel-eval--log nil)) + (fuel-eval--log t)) (when word (let ((ret (fuel-eval--eval-string/context - (format "\\ %s synopsis fuel-eval-set-result" word)))) + (format "\\ %s synopsis fuel-eval-set-result" word) + t))) (when (not (fuel-eval--retort-error ret)) (if fuel-help-minibuffer-font-lock (fuel-help--font-lock-str (fuel-eval--retort-result ret)) @@ -170,7 +171,7 @@ displayed in the minibuffer." (def (if ask (read-string prompt nil 'fuel-help--history def) def)) (cmd (format "\\ %s %s" def (if see "see" "help"))) (fuel-eval--log nil) - (ret (fuel-eval--eval-string/context cmd)) + (ret (fuel-eval--eval-string/context cmd t)) (out (fuel-eval--retort-output ret))) (if (or (fuel-eval--retort-error ret) (empty-string-p out)) (message "No help for '%s'" def) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index c741a77a5d..9fa330993c 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -59,10 +59,15 @@ buffer." (error "Could not run factor: %s is not executable" factor)) (unless (file-readable-p image) (error "Could not run factor: image file %s not readable" image)) - (setq fuel-listener-buffer - (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (setq fuel-listener-buffer (get-buffer-create "*fuel listener*")) (with-current-buffer fuel-listener-buffer - (fuel-listener-mode)))) + (fuel-listener-mode) + (message "Starting FUEL listener ...") + (comint-exec fuel-listener-buffer "factor" + factor nil `("-run=fuel" ,(format "-i=%s" image))) + (fuel-listener--wait-for-prompt 20) + (fuel-eval--send-string "USE: fuel") + (message "FUEL listener up and running!")))) (defun fuel-listener--process (&optional start) (or (and (buffer-live-p fuel-listener-buffer) @@ -74,6 +79,23 @@ buffer." (setq fuel-eval--default-proc-function 'fuel-listener--process) + +;;; Prompt chasing + +(defun fuel-listener--wait-for-prompt (&optional timeout) + (let ((proc (get-buffer-process fuel-listener-buffer)) + (seen)) + (with-current-buffer fuel-listener-buffer + (while (progn (goto-char comint-last-input-end) + (not (or seen + (setq seen + (re-search-forward comint-prompt-regexp nil t)) + (not (accept-process-output proc timeout)))))) + (goto-char (point-max))) + (unless seen + (pop-to-buffer fuel-listener-buffer) + (error "No prompt found!")))) + ;;; Interface: starting fuel listener @@ -94,30 +116,17 @@ buffer." (defconst fuel-listener--prompt-regex "( [^)]* ) ") -(defun fuel-listener--wait-for-prompt (&optional timeout) - (let ((proc (fuel-listener--process))) - (with-current-buffer fuel-listener-buffer - (goto-char comint-last-input-end) - (while (not (or (re-search-forward comint-prompt-regexp nil t) - (not (accept-process-output proc timeout)))) - (goto-char comint-last-input-end)) - (goto-char (point-max))))) - -(defun fuel-listener--startup () - (fuel-listener--wait-for-prompt) - (fuel-eval--send-string "USE: fuel") - (message "FUEL listener up and running!")) - (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" "Major mode for interacting with an inferior Factor listener process. \\{fuel-listener-mode-map}" (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex) (set (make-local-variable 'comint-prompt-read-only) t) - (fuel-listener--startup)) + (setq fuel-listener--compilation-begin nil)) -;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) -;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) +(define-key fuel-listener-mode-map "\C-ch" 'fuel-help) +(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point) +(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file) (provide 'fuel-listener) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index bd9b127c7d..0a459e4381 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -18,6 +18,7 @@ (require 'fuel-base) (require 'fuel-syntax) (require 'fuel-font-lock) +(require 'fuel-debug) (require 'fuel-help) (require 'fuel-eval) (require 'fuel-listener) @@ -37,33 +38,58 @@ ;;; User commands +(defun fuel-run-file (&optional arg) + "Sends the current file to Factor for compilation. +With prefix argument, ask for the file to run." + (interactive "P") + (let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t)) + (buffer-file-name))) + (file (expand-file-name file)) + (buffer (find-file-noselect file)) + (cmd (format "%S fuel-run-file" file))) + (when buffer + (with-current-buffer buffer + (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) + (format "%s successfully compiled" file) + nil + file))))) + (defun fuel-eval-region (begin end &optional arg) "Sends region to Fuel's listener for evaluation. -With prefix, switchs to the listener's buffer afterwards." +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "r\nP") - (let* ((ret (fuel-eval--eval-region/context begin end)) - (err (fuel-eval--retort-error ret))) - (message "%s" (or err (fuel--shorten-region begin end 70)))) - (when arg (pop-to-buffer fuel-listener-buffer))) + (fuel-debug--display-retort + (fuel-eval--eval-region/context begin end) + (format "%s%s" + (if fuel-syntax--current-vocab + (format "IN: %s " fuel-syntax--current-vocab) + "") + (fuel--shorten-region begin end 70)) + arg + (buffer-file-name))) (defun fuel-eval-extended-region (begin end &optional arg) "Sends region extended outwards to nearest definitions, -to Fuel's listener for evaluation. With prefix, switchs to the -listener's buffer afterwards." +to Fuel's listener for evaluation. +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "r\nP") (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) - (save-excursion (goto-char end) (mark-defun) (mark)))) + (save-excursion (goto-char end) (mark-defun) (mark)) + arg)) (defun fuel-eval-definition (&optional arg) "Sends definition around point to Fuel's listener for evaluation. -With prefix, switchs to the listener's buffer afterwards." +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "P") (save-excursion (mark-defun) (let* ((begin (point)) (end (mark))) (unless (< begin end) (error "No evaluable definition around point")) - (fuel-eval-region begin end)))) + (fuel-eval-region begin end arg)))) (defun fuel-edit-word-at-point (&optional arg) "Opens a new window visiting the definition of the word at point. @@ -128,6 +154,9 @@ interacting with a factor listener is at your disposal. (fuel-mode--key-1 ?z 'run-factor) +(fuel-mode--key-1 ?k 'fuel-run-file) +(fuel-mode--key ?e ?k 'fuel-run-file) + (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) (fuel-mode--key ?e ?x 'fuel-eval-definition) From 6745e0dad9e7b46878b483e4d28fc6316f46b6fb Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 9 Dec 2008 12:35:59 -0800 Subject: [PATCH 29/36] Fix error in the docs for assoc-map. --- core/assocs/assocs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b02e0189b2..662d667485 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -214,7 +214,7 @@ HELP: assoc-map { $examples { $unchecked-example ": discount ( prices n -- newprices )" - " [ - ] curry assoc-each ;" + " [ - ] curry assoc-map ;" "H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }" "2 discount ." "H{ { \"bananas\" 3 } { \"apples\" 39 } { \"pears\" 15 } }" From ea4feee886fc3f62d12e6fb40890931045ff6d2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 15:10:51 -0600 Subject: [PATCH 30/36] Fix typo --- core/classes/tuple/tuple-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 3bac6c87b3..5b1844b78b 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -197,7 +197,7 @@ ARTICLE: "tuple-introspection" "Tuple introspection" ARTICLE: "tuple-examples" "Tuple examples" "An example:" -{ $code "TUPLE: employee name salary position ;" } +{ $code "TUPLE: employee name position salary ;" } "This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:" { $table { "Reader" "Writer" "Setter" "Changer" } @@ -237,7 +237,7 @@ ARTICLE: "tuple-examples" "Tuple examples" " checks counter check boa ;" "" ": biweekly-paycheck ( employee -- check )" - " dup name>> swap salary>> 26 / ;" + " [ name>> ] [ salary>> 26 / ] bi ;" } "An example of using a changer:" { $code From 9ad51490afe7d5354d8575f8bf943596d44bc2dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:26:30 -0600 Subject: [PATCH 31/36] Fix GC crash with -generations=2 --- vm/code_heap.c | 2 ++ vm/data_gc.c | 4 +--- vm/data_gc.h | 1 + 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/vm/code_heap.c b/vm/code_heap.c index 6ed5ea4309..9a1c45c7df 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -147,6 +147,8 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) /* Perform all fixups on a code block */ void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { + compiled->last_scan = NURSERY; + if(compiled->relocation != F) { F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); diff --git a/vm/data_gc.c b/vm/data_gc.c index 6e15718b2d..2122f930f0 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -32,9 +32,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, data_heap->gen_count = gens; CELL total_size; - if(data_heap->gen_count == 1) - total_size = 2 * tenured_size; - else if(data_heap->gen_count == 2) + if(data_heap->gen_count == 2) total_size = young_size + 2 * tenured_size; else if(data_heap->gen_count == 3) total_size = young_size + 2 * aging_size + 2 * tenured_size; diff --git a/vm/data_gc.h b/vm/data_gc.h index 4ec3fdd5f2..6d367a25fd 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -137,6 +137,7 @@ void collect_cards(void); /* the oldest generation */ #define TENURED (data_heap->gen_count-1) +#define MIN_GEN_COUNT 1 #define MAX_GEN_COUNT 3 /* used during garbage collection only */ From d771e8a30619d29b56ed6396fe8354627efc66c3 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 9 Dec 2008 23:37:27 +0100 Subject: [PATCH 32/36] FUEL debug mode: :warnings &co. retrievable, and some cosmetics. --- extra/fuel/fuel.factor | 17 +++--- misc/fuel/fuel-debug.el | 124 +++++++++++++++++++++++++--------------- misc/fuel/fuel-mode.el | 10 ++-- 3 files changed, 92 insertions(+), 59 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index acaccf5b78..d9db83b5e3 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,21 +104,20 @@ M: source-file fuel-pprint path>> fuel-pprint ; fuel-eval-output get-global 3array fuel-pprint ; -: fuel-forget-error ( -- ) - f error set-global ; inline +: fuel-forget-error ( -- ) f error set-global ; inline +: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline +: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline : (fuel-begin-eval) ( -- ) push-fuel-status display-stacks? off fuel-forget-error - f fuel-eval-result set-global - f fuel-eval-output set-global ; - -: fuel-run-with-output ( quot -- ) - with-string-writer fuel-eval-output set-global ; inline + fuel-forget-result + fuel-forget-output ; : (fuel-end-eval) ( quot -- ) - fuel-run-with-output fuel-retort pop-fuel-status ; inline + with-string-writer fuel-eval-output set-global + fuel-retort pop-fuel-status ; inline : (fuel-eval) ( lines -- ) [ [ parse-lines ] with-compilation-unit call ] curry @@ -129,7 +128,7 @@ M: source-file fuel-pprint path>> fuel-pprint ; : (fuel-eval-usings) ( usings -- ) [ "USING: " prepend " ;" append ] map - (fuel-eval-each) fuel-forget-error ; + (fuel-eval-each) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index 1b68f6e79f..b3aad7f3dc 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -45,7 +45,42 @@ (restart-name function-name "restart names"))) -;;; Compilation results buffer: +;;; Font lock and other pattern matching: + +(defconst fuel-debug--compiler-info-alist + '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l))) + +(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") +(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") +(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") + +(defconst fuel-debug--error-regex + (format "%s\n%s" + fuel-debug--error-file-regex + fuel-debug--error-line-regex)) + +(defconst fuel-debug--compiler-info-regex + (format "^\\(%s\\) " + (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist)))) + +(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)") + +(defconst fuel-debug--font-lock-keywords + `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) + (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) + (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) + (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) + (2 'fuel-debug-font-lock-restart-name)) + (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number) + ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) + ("^Error: " . 'fuel-debug-font-lock-error))) + +(defun fuel-debug--font-lock-setup () + (set (make-local-variable 'font-lock-defaults) + '(fuel-debug--font-lock-keywords t nil nil nil))) + + +;;; Debug buffer: (defvar fuel-debug--buffer nil) @@ -67,50 +102,63 @@ (inhibit-read-only t)) (with-current-buffer (fuel-debug--buffer) (erase-buffer) - (when err (insert (format "Error: %S\n\n" (fuel-eval--error-name err)))) - (fuel-debug--display-output-1 ret) + (fuel-debug--display-output ret) + (delete-blank-lines) + (newline) (when (and (not err) success-msg) (message "%s" success-msg) (insert "\n" success-msg "\n")) (when err (fuel-debug--display-restarts err) - (let ((hstr (fuel-debug--help-string err))) + (delete-blank-lines) + (newline) + (let ((hstr (fuel-debug--help-string err file))) (if fuel-debug-show-short-help (insert "-----------\n" hstr "\n") (message "%s" hstr)))) (setq fuel-debug--last-ret ret) (setq fuel-debug--file file) - (goto-char (point-max))) - (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)))) + (goto-char (point-max)) + (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)) + (not err)))) -(defun fuel-debug--display-output-1 (ret) +(defun fuel-debug--display-output (ret) (let* ((last (fuel-eval--retort-output fuel-debug--last-ret)) (current (fuel-eval--retort-output ret)) (llen (length last)) (clen (length current)) (trail (and last (substring-no-properties last (/ llen 2)))) + (err (fuel-eval--retort-error ret)) (p (point))) (save-excursion (insert current)) (when (and (> clen llen) (> llen 0) (search-forward trail nil t)) (delete-region p (point))) - (goto-char (point-max)))) + (goto-char (point-max)) + (when err + (insert (format "\nError: %S\n\n" (fuel-eval--error-name err)))))) (defun fuel-debug--display-restarts (err) (let* ((rs (fuel-eval--error-restarts err)) (rsn (length rs))) (when rs - (insert "\n\nRestarts:\n\n") + (insert "Restarts:\n\n") (dotimes (n rsn) (insert (format ":%s %s\n" (1+ n) (nth n rs)))) (newline)))) -(defun fuel-debug--help-string (err) - (format "Press %s%s 'q' to bury buffer" - (if (fuel-eval--error-file err) "g to visit file, " "") +(defun fuel-debug--help-string (err &optional file) + (format "Press %s%s%sq bury buffer" + (if (or file (fuel-eval--error-file err)) "g go to file, " "") (let ((rsn (length (fuel-eval--error-restarts err)))) (cond ((zerop rsn) "") - ((= 1 rsn) "1 to invoke restart, ") - (t (format "1-%s to invoke restarts, " rsn)))))) + ((= 1 rsn) "1 invoke restart, ") + (t (format "1-%s invoke restarts, " rsn)))) + (let ((str "")) + (dolist (ci fuel-debug--compiler-info-alist str) + (save-excursion + (goto-char (point-min)) + (when (search-forward (car ci) nil t) + (setq str (format "%c %s, %s" (cdr ci) (car ci) str)))))))) (defun fuel-debug--buffer-file () (with-current-buffer (fuel-debug--buffer) @@ -126,44 +174,13 @@ (fuel-eval--error-restarts (fuel-debug--buffer-error))) -;;; Font lock and other pattern matching: - -(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") -(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") -(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") - -(defconst fuel-debug--error-regex - (format "%s\n%s" - fuel-debug--error-file-regex - fuel-debug--error-line-regex)) - -(defconst fuel-debug--named-restart-regex - (format "^\\(%s\\) " (regexp-opt '(":warnings" ":errors" ":linkage")))) - -(defconst fuel-debug--restart-regex - "^:\\([0-9]+\\) \\(.+\\)") - -(defconst fuel-debug--font-lock-keywords - `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) - (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) - (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) - (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) - (2 'fuel-debug-font-lock-restart-name)) - (,fuel-debug--named-restart-regex 1 'fuel-debug-font-lock-restart-number) - ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) - ("^Error: " . 'fuel-debug-font-lock-error))) - -(defun fuel-debug--font-lock-setup () - (set (make-local-variable 'font-lock-defaults) - '(fuel-debug--font-lock-keywords t nil nil nil))) - ;;; Buffer navigation: (defun fuel-debug-goto-error () (interactive) (let* ((err (or (fuel-debug--buffer-error) (error "No errors reported"))) - (file (or (fuel-eval--error-file err) + (file (or (fuel-debug--buffer-file) (error "No file associated with error"))) (l/c (fuel-eval--error-line/column err)) (line (or (car l/c) 1)) @@ -200,6 +217,16 @@ (fuel-eval--eval-string/context (format ":%s" n)) (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) +(defun fuel-debug-show--compiler-info (info) + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward (format "^%s" info) nil t) + (error "%s information not available" info)) + (message "Retrieving %s info ..." info) + (unless (fuel-debug--display-retort + (fuel-eval--eval-string info) "" (fuel-debug--buffer-file)) + (error "Sorry, no %s info available" info)))) + ;;; Fuel Debug mode: @@ -208,10 +235,15 @@ (suppress-keymap map) (define-key map "g" 'fuel-debug-goto-error) (define-key map "\C-c\C-c" 'fuel-debug-goto-error) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) (define-key map "q" 'bury-buffer) (dotimes (n 9) (define-key map (vector (+ ?1 n)) `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t)))) + (dolist (ci fuel-debug--compiler-info-alist) + (define-key map (vector (cdr ci)) + `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci))))) map)) (defun fuel-debug-mode () diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0a459e4381..ea1d4b93ed 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -49,10 +49,12 @@ With prefix argument, ask for the file to run." (cmd (format "%S fuel-run-file" file))) (when buffer (with-current-buffer buffer - (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) - (format "%s successfully compiled" file) - nil - file))))) + (message "Compiling %s ..." file) + (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) + (format "%s successfully compiled" file) + nil + file))) + (if r (message "Compiling %s ... OK!" file) (message ""))))))) (defun fuel-eval-region (begin end &optional arg) "Sends region to Fuel's listener for evaluation. From b5e8b14722cd2a8bf976741bfffc833ff2e40a65 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:45:02 -0600 Subject: [PATCH 33/36] Add unit test for GC problem --- core/memory/memory-tests.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 1c23e700ca..6794825897 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,8 +1,16 @@ USING: generic kernel kernel.private math memory prettyprint io sequences tools.test words namespaces layouts classes -classes.builtin arrays quotations ; +classes.builtin arrays quotations io.launcher system ; IN: memory.tests +! LOL +[ ] [ + vm + "-generations=2" + "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit" + 3array try-process +] unit-test + [ [ ] instances ] must-infer ! Code GC wasn't kicking in when needed From a90118da5dac22baab0f1a0d495130842ece2c56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:54:48 -0600 Subject: [PATCH 34/36] Add inc-at word to core, and update some usages of at+ to use it instead --- basis/compiler/tree/debugger/debugger.factor | 4 ++-- basis/compiler/tree/propagation/inlining/inlining.factor | 2 +- basis/locals/locals-docs.factor | 2 ++ basis/logging/analysis/analysis.factor | 6 +++--- basis/tools/memory/memory.factor | 2 +- core/assocs/assocs-docs.factor | 6 ++++++ core/assocs/assocs.factor | 5 +++-- 7 files changed, 18 insertions(+), 9 deletions(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8a2823010d..e75e7f6046 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -151,14 +151,14 @@ SYMBOL: node-count H{ } clone intrinsics-called set 0 swap [ - >r 1+ r> + [ 1+ ] dip dup #call? [ word>> { { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } [ words-called ] - } cond 1 -rot get at+ + } cond inc-at ] [ drop ] if ] each-node node-count set diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e35eb02604..bd6d657442 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -152,7 +152,7 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - [ [ 1 ] dip inlining-count get at+ ] + [ inlining-count get inc-at ] [ history [ swap suffix ] change ] bi ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index e9e1bfa16a..77b87d1b49 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -67,6 +67,8 @@ HELP: :> { $syntax ":> binding" } { $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } { $notes + "This word can only be used inside a lambda word, lambda quotation or let binding form." + $nl "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "." $nl "Lambdas desugar as follows:" diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index d84e49f784..24810a6c3e 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -13,10 +13,10 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when - 1 over word-name>> word-histogram get at+ + dup word-name>> word-histogram get inc-at dup word-name>> word-names get member? [ - 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array - message-histogram get at+ + dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get inc-at ] when drop ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 8c35ae25a8..2ad16a4d8d 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -53,7 +53,7 @@ IN: tools.memory : heap-stat-step ( obj counts sizes -- ) [ over ] dip - [ [ [ drop 1 ] [ class ] bi ] dip at+ ] + [ [ class ] dip inc-at ] [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ; PRIVATE> diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 662d667485..2f486cd948 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -90,6 +90,7 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs" { $subsection rename-at } { $subsection change-at } { $subsection at+ } +{ $subsection inc-at } { $see-also set-at delete-at clear-assoc push-at } ; ARTICLE: "assocs-conversions" "Associative mapping conversions" @@ -349,6 +350,11 @@ HELP: at+ { $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." } { $side-effects "assoc" } ; +HELP: inc-at +{ $values { "key" object } { "assoc" assoc } } +{ $description "Adds 1 to the value associated with " { $snippet "key" } "; if there is no value, stores 1." } +{ $side-effects "assoc" } ; + HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } { $contract "Converts an associative structure into an association list." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 76745cc015..320e370ec9 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -141,8 +141,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : change-at ( key assoc quot -- ) [ [ at ] dip call ] 3keep drop set-at ; inline -: at+ ( n key assoc -- ) - [ 0 or + ] change-at ; +: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline + +: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline : map>assoc ( seq quot exemplar -- assoc ) [ [ 2array ] compose { } map-as ] dip assoc-like ; inline From 4b927f732f90a6f4076fe82c0e6154aefd85ca93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 17:14:17 -0600 Subject: [PATCH 35/36] Clean up JIT backend a little --- basis/cpu/x86/32/bootstrap.factor | 14 +- basis/cpu/x86/64/bootstrap.factor | 15 +- basis/cpu/x86/64/unix/bootstrap.factor | 3 - basis/cpu/x86/64/winnt/bootstrap.factor | 3 - basis/cpu/x86/bootstrap.factor | 434 ++++++++++++++---------- 5 files changed, 274 insertions(+), 195 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 04bdcca68b..698c3a1766 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -10,19 +10,19 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) ECX ; : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; -: arg0 ( -- reg ) EAX ; -: arg1 ( -- reg ) EDX ; -: arg2 ( -- reg ) ECX ; -: temp-reg ( -- reg ) EBX ; +: temp0 ( -- reg ) EAX ; +: temp1 ( -- reg ) EDX ; +: temp2 ( -- reg ) ECX ; +: temp3 ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; -: fixnum>slot@ ( -- ) arg0 1 SAR ; +: fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 0 ; [ - arg0 0 [] MOV ! load stack_chain - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 [] MOV ! load stack_chain + temp0 [] stack-reg MOV ! save stack pointer ] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define [ diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 83a72d6dd3..efa3de3065 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -9,7 +9,10 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) RCX ; : div-arg ( -- reg ) RAX ; : mod-arg ( -- reg ) RDX ; -: temp-reg ( -- reg ) RBX ; +: temp0 ( -- reg ) RDI ; +: temp1 ( -- reg ) RSI ; +: temp2 ( -- reg ) RDX ; +: temp3 ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; @@ -17,14 +20,14 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - arg0 0 MOV ! load stack_chain - arg0 arg0 [] MOV - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 MOV ! load stack_chain + temp0 temp0 [] MOV + temp0 [] stack-reg MOV ! save stack pointer ] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define [ - arg1 0 MOV ! load XT - arg1 JMP ! go + temp1 0 MOV ! load XT + temp1 JMP ! go ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index f0ca56da14..a21c4534d2 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; -: arg0 ( -- reg ) RDI ; -: arg1 ( -- reg ) RSI ; -: arg2 ( -- reg ) RDX ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 459945d82e..709f138463 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; -: arg0 ( -- reg ) RCX ; -: arg1 ( -- reg ) RDX ; -: arg2 ( -- reg ) R8 ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 597a2c9d31..3451da78e1 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -12,28 +12,35 @@ big-endian off [ ! Load word - temp-reg 0 MOV + temp0 0 MOV ! Bump profiling counter - temp-reg profile-count-offset [+] 1 tag-fixnum ADD + temp0 profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code - temp-reg temp-reg word-code-offset [+] MOV + temp0 temp0 word-code-offset [+] MOV ! Compute word XT - temp-reg compiled-header-size ADD + temp0 compiled-header-size ADD ! Jump to XT - temp-reg JMP + temp0 JMP ] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define [ - temp-reg 0 MOV ! load XT - stack-frame-size PUSH ! save stack frame size - temp-reg PUSH ! push XT - stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment + ! load XT + temp0 0 MOV + ! save stack frame size + stack-frame-size PUSH + ! push XT + temp0 PUSH + ! alignment + stack-reg stack-frame-size 3 bootstrap-cells - SUB ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define [ - arg0 0 MOV ! load literal - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack + ! load literal + temp0 0 MOV + ! increment datastack pointer + ds-reg bootstrap-cell ADD + ! store literal on datastack + ds-reg [] temp0 MOV ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define [ @@ -45,73 +52,85 @@ big-endian off ] rc-relative rt-xt 1 jit-word-call jit-define [ - arg0 ds-reg [] MOV ! load boolean - ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare boolean with f - f JNE ! jump to true branch if not equal + ! load boolean + temp0 ds-reg [] MOV + ! pop boolean + ds-reg bootstrap-cell SUB + ! compare boolean with f + temp0 \ f tag-number CMP + ! jump to true branch if not equal + f JNE ] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define [ - f JMP ! jump to false branch if equal + ! jump to false branch if equal + f JMP ] rc-relative rt-xt 1 jit-if-2 jit-define [ - arg1 0 MOV ! load dispatch table - arg0 ds-reg [] MOV ! load index - fixnum>slot@ ! turn it into an array offset - ds-reg bootstrap-cell SUB ! pop index - arg0 arg1 ADD ! compute quotation location - arg0 arg0 array-start-offset [+] MOV ! load quotation - arg0 quot-xt-offset [+] JMP ! execute branch + ! load dispatch table + temp1 0 MOV + ! load index + temp0 ds-reg [] MOV + ! turn it into an array offset + fixnum>slot@ + ! pop index + ds-reg bootstrap-cell SUB + ! compute quotation location + temp0 temp1 ADD + ! load quotation + temp0 temp0 array-start-offset [+] MOV + ! execute branch + temp0 quot-xt-offset [+] JMP ] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - rs-reg [] arg0 MOV ; + rs-reg [] temp0 MOV ; : jit-2>r ( -- ) rs-reg 2 bootstrap-cells ADD - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg 2 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3>r ( -- ) rs-reg 3 bootstrap-cells ADD - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - arg2 ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp2 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV - rs-reg -2 bootstrap-cells [+] arg2 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 MOV + rs-reg -2 bootstrap-cells [+] temp2 MOV ; : jit-r> ( -- ) ds-reg bootstrap-cell ADD - arg0 rs-reg [] MOV + temp0 rs-reg [] MOV rs-reg bootstrap-cell SUB - ds-reg [] arg0 MOV ; + ds-reg [] temp0 MOV ; : jit-2r> ( -- ) ds-reg 2 bootstrap-cells ADD - arg0 rs-reg [] MOV - arg1 rs-reg -1 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV rs-reg 2 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3r> ( -- ) ds-reg 3 bootstrap-cells ADD - arg0 rs-reg [] MOV - arg1 rs-reg -1 bootstrap-cells [+] MOV - arg2 rs-reg -2 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV + temp2 rs-reg -2 bootstrap-cells [+] MOV rs-reg 3 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg2 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp2 MOV ; [ jit->r @@ -126,13 +145,14 @@ big-endian off ] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define [ - jit-3>r + jit-3>r f CALL jit-3r> ] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define [ - stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame + ! unwind stack frame + stack-reg stack-frame-size bootstrap-cell - ADD ] f f f jit-epilog jit-define [ 0 RET ] f f f jit-return jit-define @@ -141,34 +161,51 @@ big-endian off ! Quotations and words [ - arg0 ds-reg [] MOV ! load from stack - ds-reg bootstrap-cell SUB ! pop stack - arg0 quot-xt-offset [+] JMP ! call quotation + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! call quotation + temp0 quot-xt-offset [+] JMP ] f f f \ (call) define-sub-primitive [ - arg0 ds-reg [] MOV ! load from stack - ds-reg bootstrap-cell SUB ! pop stack - arg0 word-xt-offset [+] JMP ! execute word + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! execute word + temp0 word-xt-offset [+] JMP ] f f f \ (execute) define-sub-primitive ! Objects [ - arg1 ds-reg [] MOV ! load from stack - arg1 tag-mask get AND ! compute tag - arg1 tag-bits get SHL ! tag the tag - ds-reg [] arg1 MOV ! push to stack + ! load from stack + temp0 ds-reg [] MOV + ! compute tag + temp0 tag-mask get AND + ! tag the tag + temp0 tag-bits get SHL + ! push to stack + ds-reg [] temp0 MOV ] f f f \ tag define-sub-primitive [ - arg0 ds-reg [] MOV ! load slot number - ds-reg bootstrap-cell SUB ! adjust stack pointer - arg1 ds-reg [] MOV ! load object - fixnum>slot@ ! turn slot number into offset - arg1 tag-bits get SHR ! mask off tag - arg1 tag-bits get SHL - arg0 arg1 arg0 [+] MOV ! load slot value - ds-reg [] arg0 MOV ! push to stack + ! load slot number + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load object + temp1 ds-reg [] MOV + ! turn slot number into offset + fixnum>slot@ + ! mask off tag + temp1 tag-bits get SHR + temp1 tag-bits get SHL + ! load slot value + temp0 temp1 temp0 [+] MOV + ! push to stack + ds-reg [] temp0 MOV ] f f f \ slot define-sub-primitive ! Shufflers @@ -185,100 +222,100 @@ big-endian off ] f f f \ 3drop define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ dup define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg bootstrap-cell neg [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV ds-reg 2 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg bootstrap-cell neg [+] arg1 MOV + ds-reg [] temp0 MOV + ds-reg bootstrap-cell neg [+] temp1 MOV ] f f f \ 2dup define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] temp-reg MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp3 MOV ] f f f \ 3dup define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ nip define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg 2 bootstrap-cells SUB - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ 2nip define-sub-primitive [ - arg0 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ over define-sub-primitive [ - arg0 ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg -2 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ pick define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + ds-reg [] temp1 MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ dupd define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV ] f f f \ tuck define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg bootstrap-cell neg [+] MOV - ds-reg bootstrap-cell neg [+] arg0 MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] temp0 MOV + ds-reg [] temp1 MOV ] f f f \ swap define-sub-primitive [ - arg0 ds-reg -1 bootstrap-cells [+] MOV - arg1 ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV + temp0 ds-reg -1 bootstrap-cells [+] MOV + temp1 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ] f f f \ swapd define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg1 MOV - ds-reg -1 bootstrap-cells [+] arg0 MOV - ds-reg [] temp-reg MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp1 MOV + ds-reg -1 bootstrap-cells [+] temp0 MOV + ds-reg [] temp3 MOV ] f f f \ rot define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] temp-reg MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp3 MOV + ds-reg [] temp1 MOV ] f f f \ -rot define-sub-primitive [ jit->r ] f f f \ >r define-sub-primitive @@ -287,14 +324,20 @@ big-endian off ! Comparisons : jit-compare ( insn -- ) - temp-reg 0 MOV ! load t - arg1 \ f tag-number MOV ! load f - arg0 ds-reg [] MOV ! load first value - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] arg0 CMP ! compare with second value - [ arg1 temp-reg ] dip execute ! move t if true - ds-reg [] arg1 MOV ! store - ; + ! load t + temp3 0 MOV + ! load f + temp1 \ f tag-number MOV + ! load first value + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! compare with second value + ds-reg [] temp0 CMP + ! move t if true + [ temp1 temp3 ] dip execute + ! store + ds-reg [] temp1 MOV ; : define-jit-compare ( insn word -- ) [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip @@ -308,22 +351,30 @@ big-endian off ! Math : jit-math ( insn -- ) - arg0 ds-reg [] MOV ! load second input - ds-reg bootstrap-cell SUB ! pop stack - [ ds-reg [] arg0 ] dip execute ! compute result - ; + ! load second input + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! compute result + [ ds-reg [] temp0 ] dip execute ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive [ - arg0 ds-reg [] MOV ! load second input - ds-reg bootstrap-cell SUB ! pop stack - arg1 ds-reg [] MOV ! load first input - arg0 tag-bits get SAR ! untag second input - arg0 arg1 IMUL2 ! multiply - ds-reg [] arg1 MOV ! push result + ! load second input + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! load first input + temp1 ds-reg [] MOV + ! untag second input + temp0 tag-bits get SAR + ! multiply + temp0 temp1 IMUL2 + ! push result + ds-reg [] temp1 MOV ] f f f \ fixnum*fast define-sub-primitive [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive @@ -333,75 +384,106 @@ big-endian off [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive [ - ds-reg [] NOT ! complement - ds-reg [] tag-mask get XOR ! clear tag bits + ! complement + ds-reg [] NOT + ! clear tag bits + ds-reg [] tag-mask get XOR ] f f f \ fixnum-bitnot define-sub-primitive [ - shift-arg ds-reg [] MOV ! load shift count - shift-arg tag-bits get SAR ! untag shift count - ds-reg bootstrap-cell SUB ! adjust stack pointer - temp-reg ds-reg [] MOV ! load value - arg1 temp-reg MOV ! make a copy - arg1 CL SHL ! compute positive shift value in arg1 - shift-arg NEG ! compute negative shift value in arg0 - temp-reg CL SAR - temp-reg tag-mask get bitnot AND - shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1 - arg1 temp-reg CMOVGE - ds-reg [] arg1 MOV ! push to stack + ! load shift count + shift-arg ds-reg [] MOV + ! untag shift count + shift-arg tag-bits get SAR + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load value + temp3 ds-reg [] MOV + ! make a copy + temp1 temp3 MOV + ! compute positive shift value in temp1 + temp1 CL SHL + shift-arg NEG + ! compute negative shift value in temp3 + temp3 CL SAR + temp3 tag-mask get bitnot AND + shift-arg 0 CMP + ! if shift count was negative, move temp0 to temp1 + temp1 temp3 CMOVGE + ! push to stack + ds-reg [] temp1 MOV ] f f f \ fixnum-shift-fast define-sub-primitive : jit-fixnum-/mod ( -- ) - temp-reg ds-reg [] MOV ! load second parameter - div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter - mod-arg div-arg MOV ! make a copy - mod-arg bootstrap-cell-bits 1- SAR ! sign-extend - temp-reg IDIV ; ! divide + ! load second parameter + temp3 ds-reg [] MOV + ! load first parameter + div-arg ds-reg bootstrap-cell neg [+] MOV + ! make a copy + mod-arg div-arg MOV + ! sign-extend + mod-arg bootstrap-cell-bits 1- SAR + ! divide + temp3 IDIV ; [ jit-fixnum-/mod - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] mod-arg MOV ! push to stack + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! push to stack + ds-reg [] mod-arg MOV ] f f f \ fixnum-mod define-sub-primitive [ jit-fixnum-/mod - ds-reg bootstrap-cell SUB ! adjust stack pointer - div-arg tag-bits get SHL ! tag it - ds-reg [] div-arg MOV ! push to stack + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! tag it + div-arg tag-bits get SHL + ! push to stack + ds-reg [] div-arg MOV ] f f f \ fixnum/i-fast define-sub-primitive [ jit-fixnum-/mod - div-arg tag-bits get SHL ! tag it - ds-reg [] mod-arg MOV ! push to stack + ! tag it + div-arg tag-bits get SHL + ! push to stack + ds-reg [] mod-arg MOV ds-reg bootstrap-cell neg [+] div-arg MOV ] f f f \ fixnum/mod-fast define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - arg0 ds-reg [] OR - arg0 tag-mask get AND - arg0 \ f tag-number MOV - arg1 1 tag-fixnum MOV - arg0 arg1 CMOVE - ds-reg [] arg0 MOV + temp0 ds-reg [] OR + temp0 tag-mask get AND + temp0 \ f tag-number MOV + temp1 1 tag-fixnum MOV + temp0 temp1 CMOVE + ds-reg [] temp0 MOV ] f f f \ both-fixnums? define-sub-primitive [ - arg0 ds-reg [] MOV ! load local number - fixnum>slot@ ! turn local number into offset - arg0 rs-reg arg0 [+] MOV ! load local value - ds-reg [] arg0 MOV ! push to stack + ! load local number + temp0 ds-reg [] MOV + ! turn local number into offset + fixnum>slot@ + ! load local value + temp0 rs-reg temp0 [+] MOV + ! push to stack + ds-reg [] temp0 MOV ] f f f \ get-local define-sub-primitive [ - arg0 ds-reg [] MOV ! load local count - ds-reg bootstrap-cell SUB ! adjust stack pointer - fixnum>slot@ ! turn local number into offset - rs-reg arg0 SUB ! decrement retain stack pointer + ! load local count + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! turn local number into offset + fixnum>slot@ + ! decrement retain stack pointer + rs-reg temp0 SUB ] f f f \ drop-locals define-sub-primitive [ "bootstrap.x86" forget-vocab ] with-compilation-unit From c2504f207d18d477bc1a5c550cb8821b77b8844a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 17:49:03 -0600 Subject: [PATCH 36/36] Use kqueue on Mac OS X instead of select --- basis/io/unix/backend/backend.factor | 4 +-- basis/io/unix/kqueue/kqueue.factor | 40 ++++++++++++---------------- basis/io/unix/macosx/macosx.factor | 6 ++++- basis/unix/kqueue/kqueue.factor | 3 ++- 4 files changed, 26 insertions(+), 27 deletions(-) diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 85363c8404..1666d60c83 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -64,10 +64,10 @@ M: mx remove-output-callbacks writes>> delete-at* drop ; GENERIC: wait-for-events ( ms mx -- ) : input-available ( fd mx -- ) - remove-input-callbacks [ resume ] each ; + reads>> delete-at* drop [ resume ] each ; : output-available ( fd mx -- ) - remove-output-callbacks [ resume ] each ; + writes>> delete-at* drop [ resume ] each ; M: fd cancel-operation ( fd -- ) dup disposed>> [ drop ] [ diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 6b687a8afb..b4e2b7af6f 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types combinators io.unix.backend kernel math.bitwise sequences struct-arrays unix unix.kqueue -unix.time ; +unix.time assocs ; IN: io.unix.kqueue -TUPLE: kqueue-mx < mx events monitors ; +TUPLE: kqueue-mx < mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -14,7 +14,6 @@ TUPLE: kqueue-mx < mx events monitors ; : ( -- mx ) kqueue-mx new-mx - H{ } clone >>monitors kqueue dup io-error >>fd max-events "kevent" >>events ; @@ -35,30 +34,25 @@ M: kqueue-mx add-input-callback ( thread fd mx -- ) M: kqueue-mx add-output-callback ( thread fd mx -- ) [ call-next-method ] [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip + [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip register-kevent ] 2bi ; -: cancel-input-callbacks ( fd mx -- seq ) - [ - [ EVFILT_READ EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-input-callbacks ] 2bi ; +M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ + [ EVFILT_READ EV_DELETE make-kevent ] dip + register-kevent + ] 2bi + ] [ 2drop f ] if ; -: cancel-output-callbacks ( fd mx -- seq ) - [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-output-callbacks ] 2bi ; - -M: fd cancel-operation ( fd -- ) - dup disposed>> [ drop ] [ - fd>> - mx get-global - [ cancel-input-callbacks [ t swap resume-with ] each ] - [ cancel-output-callbacks [ t swap resume-with ] each ] - 2bi - ] if ; +M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; : wait-kevent ( mx timespec -- n ) [ diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor index 77140b81c9..ef52b676fb 100644 --- a/basis/io/unix/macosx/macosx.factor +++ b/basis/io/unix/macosx/macosx.factor @@ -1,6 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.macosx -USING: io.unix.bsd io.backend system ; +USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend +namespaces system ; + +M: macosx init-io ( -- ) + mx set-global ; macosx set-io-backend diff --git a/basis/unix/kqueue/kqueue.factor b/basis/unix/kqueue/kqueue.factor index 83c3bb5232..d7623df8be 100644 --- a/basis/unix/kqueue/kqueue.factor +++ b/basis/unix/kqueue/kqueue.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader words ; +USING: alien.syntax system sequences vocabs.loader words +accessors ; IN: unix.kqueue << "unix.kqueue." os name>> append require >>