From 22f11f24c9868037e190f35b6f3eb8d9daadbce0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Nov 2008 17:23:08 -0600 Subject: [PATCH 01/12] Move simple-table. to prettyprint since its generally useful and not specific to tools.time --- basis/prettyprint/prettyprint.factor | 14 ++++++++++++++ basis/tools/time/time.factor | 14 -------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index f63ce44c71..b0293a8759 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -134,6 +134,20 @@ PRIVATE> : pprint-cell ( obj -- ) [ pprint ] with-cell ; +: simple-table. ( values -- ) + standard-table-style [ + [ + [ + [ + dup string? + [ [ write ] with-cell ] + [ pprint-cell ] + if + ] each + ] with-row + ] each + ] tabular-output ; + GENERIC: see ( defspec -- ) : comment. ( string -- ) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 3078f40e1a..6873d68316 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -7,20 +7,6 @@ IN: tools.time : benchmark ( quot -- runtime ) millis >r call millis r> - ; inline -: simple-table. ( values -- ) - standard-table-style [ - [ - [ - [ - dup string? - [ [ write ] with-cell ] - [ pprint-cell ] - if - ] each - ] with-row - ] each - ] tabular-output ; - : time. ( data -- ) unclip "==== RUNNING TIME" print nl pprint " ms" print nl From c8521ad826546d1ab4426e9c5ed59aaf8c12953e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Nov 2008 17:23:20 -0600 Subject: [PATCH 02/12] Add tool to dump live intervals --- .../cfg/linear-scan/debugger/debugger.factor | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index 89bf81d2ba..c6481b305e 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences sets arrays -compiler.cfg.linear-scan.live-intervals +USING: accessors kernel sequences sets arrays math strings fry +prettyprint compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation ; IN: compiler.cfg.linear-scan.debugger @@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger : check-linear-scan ( live-intervals machine-registers -- ) [ [ clone ] map ] dip allocate-registers [ split-children ] map concat check-assigned ; + +: picture ( uses -- str ) + dup peek 1 + CHAR: space + [ '[ CHAR: * swap _ set-nth ] each ] keep ; + +: interval-picture ( interval -- str ) + [ uses>> picture ] + [ copy-from>> unparse ] + [ vreg>> unparse ] + tri 3array ; + +: live-intervals. ( seq -- ) + [ interval-picture ] map simple-table. ; From 10d3b4a55d63df3002d1d91ad9ca2d3701857d7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 00:31:08 -0600 Subject: [PATCH 03/12] New PPC backend (untested) --- basis/cpu/ppc/allot/allot.factor | 112 --- basis/cpu/ppc/allot/authors.txt | 1 - basis/cpu/ppc/allot/summary.txt | 1 - basis/cpu/ppc/allot/tags.txt | 1 - .../cpu/ppc/architecture/architecture.factor | 331 --------- basis/cpu/ppc/architecture/authors.txt | 1 - basis/cpu/ppc/architecture/summary.txt | 1 - basis/cpu/ppc/architecture/tags.txt | 1 - basis/cpu/ppc/intrinsics/authors.txt | 1 - basis/cpu/ppc/intrinsics/intrinsics.factor | 640 ------------------ basis/cpu/ppc/intrinsics/tags.txt | 1 - basis/cpu/ppc/ppc.factor | 558 ++++++++++++++- 12 files changed, 553 insertions(+), 1096 deletions(-) delete mode 100644 basis/cpu/ppc/allot/allot.factor delete mode 100644 basis/cpu/ppc/allot/authors.txt delete mode 100644 basis/cpu/ppc/allot/summary.txt delete mode 100644 basis/cpu/ppc/allot/tags.txt delete mode 100644 basis/cpu/ppc/architecture/architecture.factor delete mode 100644 basis/cpu/ppc/architecture/authors.txt delete mode 100644 basis/cpu/ppc/architecture/summary.txt delete mode 100644 basis/cpu/ppc/architecture/tags.txt delete mode 100755 basis/cpu/ppc/intrinsics/authors.txt delete mode 100644 basis/cpu/ppc/intrinsics/intrinsics.factor delete mode 100644 basis/cpu/ppc/intrinsics/tags.txt diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor deleted file mode 100644 index 3190973f26..0000000000 --- a/basis/cpu/ppc/allot/allot.factor +++ /dev/null @@ -1,112 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel cpu.ppc.architecture cpu.ppc.assembler -kernel.private namespaces math sequences generic arrays -compiler.generator compiler.generator.registers -compiler.generator.fixup system layouts -cpu.architecture alien ; -IN: cpu.ppc.allot - -: load-zone-ptr ( reg -- ) - >r "nursery" f r> %load-dlsym ; - -: %allot ( header size -- ) - #! Store a pointer to 'size' bytes allocated from the - #! nursery in r11. - 8 align ! align the size - 12 load-zone-ptr ! nusery -> r12 - 11 12 cell LWZ ! nursery.here -> r11 - 11 11 pick ADDI ! increment r11 - 11 12 cell STW ! r11 -> nursery.here - 11 11 rot SUBI ! old value - type-number tag-fixnum 12 LI ! compute header - 12 11 0 STW ! store header - ; - -: %store-tagged ( reg tag -- ) - >r dup fresh-object v>operand 11 r> tag-number ORI ; - -M: ppc %gc - "end" define-label - 12 load-zone-ptr - 11 12 cell LWZ ! nursery.here -> r11 - 12 12 3 cells LWZ ! nursery.end -> r12 - 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here - 11 0 12 CMP ! is here >= end? - "end" get BLE - 0 frame-required - %prepare-alien-invoke - "minor_gc" f %alien-invoke - "end" resolve-label ; - -: %allot-float ( reg -- ) - #! exits with tagged ptr to object in r12, untagged in r11 - float 16 %allot - 11 8 STFD - 12 11 float tag-number ORI - f fresh-object ; - -M: ppc %box-float ( dst src -- ) - [ v>operand ] bi@ %allot-float 12 MR ; - -: %allot-bignum ( #digits -- ) - #! 1 cell header, 1 cell length, 1 cell sign, + digits - #! length is the # of digits + sign - bignum over 3 + cells %allot - 1+ v>operand 12 LI ! compute the length - 12 11 cell STW ! store the length - ; - -: %allot-bignum-signed-1 ( reg -- ) - #! on entry, reg is a 30-bit quantity sign-extended to - #! 32-bits. - #! exits with tagged ptr to bignum in reg - [ - { "end" "non-zero" "pos" "store" } [ define-label ] each - ! is it zero? - 0 over v>operand 0 CMPI - "non-zero" get BNE - dup 0 >bignum %load-literal - "end" get B - ! it is non-zero - "non-zero" resolve-label - 1 %allot-bignum - ! is the fixnum negative? - 0 over v>operand 0 CMPI - "pos" get BGE - 1 12 LI - ! store negative sign - 12 11 2 cells STW - ! negate fixnum - dup v>operand dup -1 MULI - "store" get B - "pos" resolve-label - 0 12 LI - ! store positive sign - 12 11 2 cells STW - "store" resolve-label - ! store the number - dup v>operand 11 3 cells STW - ! tag the bignum, store it in reg - bignum %store-tagged - "end" resolve-label - ] with-scope ; - -M: ppc %box-alien ( dst src -- ) - { "end" "f" } [ define-label ] each - 0 over v>operand 0 CMPI - "f" get BEQ - alien 4 cells %allot - ! Store offset - v>operand 11 3 cells STW - f v>operand 12 LI - ! Store expired slot - 12 11 1 cells STW - ! Store underlying-alien slot - 12 11 2 cells STW - ! Store tagged ptr in reg - dup object %store-tagged - "end" get B - "f" resolve-label - f v>operand swap v>operand LI - "end" resolve-label ; diff --git a/basis/cpu/ppc/allot/authors.txt b/basis/cpu/ppc/allot/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/cpu/ppc/allot/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/ppc/allot/summary.txt b/basis/cpu/ppc/allot/summary.txt deleted file mode 100644 index 3c4941ea1d..0000000000 --- a/basis/cpu/ppc/allot/summary.txt +++ /dev/null @@ -1 +0,0 @@ -PowerPC inline memory allocation diff --git a/basis/cpu/ppc/allot/tags.txt b/basis/cpu/ppc/allot/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/cpu/ppc/allot/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor deleted file mode 100644 index f19b71f3e4..0000000000 --- a/basis/cpu/ppc/architecture/architecture.factor +++ /dev/null @@ -1,331 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types cpu.ppc.assembler -cpu.architecture generic kernel kernel.private math memory -namespaces sequences words assocs compiler.generator -compiler.generator.registers compiler.generator.fixup system -layouts classes words.private alien combinators -compiler.constants math.order make ; -IN: cpu.ppc.architecture - -! PowerPC register assignments -! r3-r10, r16-r31: integer vregs -! f0-f13: float vregs -! r11, r12: scratch -! r14: data stack -! r15: retain stack - -: ds-reg 14 ; inline -: rs-reg 15 ; inline - -: reserved-area-size ( -- n ) - os { - { linux [ 2 ] } - { macosx [ 6 ] } - } case cells ; foldable - -: lr-save ( -- n ) - os { - { linux [ 1 ] } - { macosx [ 2 ] } - } case cells ; foldable - -: param@ ( n -- x ) reserved-area-size + ; inline - -: param-save-size ( -- n ) 8 cells ; foldable - -: local@ ( n -- x ) - reserved-area-size param-save-size + + ; inline - -: factor-area-size ( -- n ) 2 cells ; foldable - -: next-save ( n -- i ) cell - ; - -: xt-save ( n -- i ) 2 cells - ; - -M: ppc stack-frame-size ( n -- i ) - local@ factor-area-size + 4 cells align ; - -M: temp-reg v>operand drop 11 ; - -M: int-regs return-reg drop 3 ; -M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ; -M: int-regs vregs - drop { - 3 4 5 6 7 8 9 10 - 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 - } ; - -M: float-regs return-reg drop 1 ; -M: float-regs param-regs - drop os H{ - { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } - { linux { 1 2 3 4 5 6 7 8 } } - } at ; -M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; - -GENERIC: loc>operand ( loc -- reg n ) - -M: ds-loc loc>operand n>> cells neg ds-reg swap ; -M: rs-loc loc>operand n>> cells neg rs-reg swap ; - -M: immediate load-literal - [ v>operand ] bi@ LOAD ; - -M: ppc load-indirect ( obj reg -- ) - [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep - dup 0 LWZ ; - -M: ppc %save-word-xt ( -- ) - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ; - -M: ppc %prologue ( n -- ) - 0 MFLR - 1 1 pick neg ADDI - 11 1 pick xt-save STW - dup 11 LI - 11 1 pick next-save STW - 0 1 rot lr-save + STW ; - -M: ppc %epilogue ( n -- ) - #! At the end of each word that calls a subroutine, we store - #! the previous link register value in r0 by popping it off - #! the stack, set the link register to the contents of r0, - #! and jump to the link register. - 0 1 pick lr-save + LWZ - 1 1 rot ADDI - 0 MTLR ; - -: (%call) ( reg -- ) MTLR BLRL ; - -: (%jump) ( reg -- ) MTCTR BCTR ; - -: %load-dlsym ( symbol dll register -- ) - 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; - -M: ppc %call ( label -- ) BL ; - -M: ppc %jump-label ( label -- ) B ; - -M: ppc %jump-f ( label -- ) - 0 "flag" operand f v>operand CMPI BEQ ; - -M: ppc %dispatch ( -- ) - [ - %epilogue-later - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here - "offset" operand "n" operand 1 SRAWI - 11 11 "offset" operand ADD - 11 dup 6 cells LWZ - 11 (%jump) - ] H{ - { +input+ { { f "n" } } } - { +scratch+ { { f "offset" } } } - } with-template ; - -M: ppc %dispatch-label ( word -- ) - 0 , rc-absolute-cell rel-word ; - -M: ppc %return ( -- ) %epilogue-later BLR ; - -M: ppc %peek ( vreg loc -- ) - >r v>operand r> loc>operand LWZ ; - -M: ppc %replace - >r v>operand r> loc>operand STW ; - -M: ppc %unbox-float ( dst src -- ) - [ v>operand ] bi@ float-offset LFD ; - -M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ; - -M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ; - -M: int-regs %save-param-reg drop 1 rot local@ STW ; - -M: int-regs %load-param-reg drop 1 rot local@ LWZ ; - -GENERIC: STF ( src dst off reg-class -- ) - -M: single-float-regs STF drop STFS ; - -M: double-float-regs STF drop STFD ; - -M: float-regs %save-param-reg >r 1 rot local@ r> STF ; - -GENERIC: LF ( dst src off reg-class -- ) - -M: single-float-regs LF drop LFS ; - -M: double-float-regs LF drop LFD ; - -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 get total-size>> + ; - -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 next-param@ LWZ - 0 1 rot local@ STW ; - -M: ppc %prepare-unbox ( -- ) - ! First parameter is top of stack - 3 ds-reg 0 LWZ - ds-reg dup cell SUBI ; - -M: ppc %unbox ( n reg-class func -- ) - ! Value must be in r3 - ! Call the unboxer - f %alien-invoke - ! Store the return value on the C stack - over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; - -M: ppc %unbox-long-long ( n func -- ) - ! Value must be in r3:r4 - ! Call the unboxer - f %alien-invoke - ! Store the return value on the C stack - [ - 3 1 pick local@ STW - 4 1 rot cell + local@ STW - ] when* ; - -M: ppc %unbox-large-struct ( n c-type -- ) - ! Value must be in r3 - ! 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 ; - -M: ppc %box ( n reg-class func -- ) - ! If the source is a stack location, load it into freg #0. - ! If the source is f, then we assume the value is already in - ! freg #0. - >r - over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if - r> f %alien-invoke ; - -M: ppc %box-long-long ( n func -- ) - >r [ - 3 1 pick local@ LWZ - 4 1 rot cell + local@ LWZ - ] when* r> f %alien-invoke ; - -: struct-return@ ( n -- n ) - [ stack-frame get params>> ] unless* local@ ; - -M: ppc %prepare-box-struct ( -- ) - #! Compute target address for value struct return - 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 - ! Compute destination address and load struct size - [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi* - ! Call the function - "box_value_struct" f %alien-invoke ; - -M: ppc %prepare-alien-invoke - #! Save Factor stack pointers in case the C code calls a - #! callback which does a GC, which must reliably trace - #! all roots. - "stack_chain" f 11 %load-dlsym - 11 11 0 LWZ - 1 11 0 STW - ds-reg 11 8 STW - rs-reg 11 12 STW ; - -M: ppc %alien-invoke ( symbol dll -- ) - 11 %load-dlsym 11 (%call) ; - -M: ppc %alien-callback ( quot -- ) - 3 load-indirect "c_to_factor" f %alien-invoke ; - -M: ppc %prepare-alien-indirect ( -- ) - "unbox_alien" f %alien-invoke - 13 3 MR ; - -M: ppc %alien-indirect ( -- ) - 13 (%call) ; - -M: ppc %callback-value ( ctype -- ) - ! Save top of data stack - 3 ds-reg 0 LWZ - 3 1 0 local@ STW - ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke - ! Restore top of data stack - 3 1 0 local@ LWZ - ! Unbox former top of data stack to return registers - unbox-return ; - -: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ; - -: %tag-fixnum ( src dest -- ) tag-bits get SLWI ; - -: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ; - -M: ppc value-structs? - #! On Linux/PPC, value structs are passed in the same way - #! as reference structs, we just have to make a copy first. - os linux? not ; - -M: ppc fp-shadows-int? ( -- ? ) os macosx? ; - -M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; - -M: ppc struct-small-enough? ( size -- ? ) drop f ; - -M: ppc %box-small-struct - drop "No small structs" throw ; - -M: ppc %unbox-small-struct - drop "No small structs" throw ; - -! Alien intrinsics -M: ppc %unbox-byte-array ( dst src -- ) - [ v>operand ] bi@ byte-array-offset ADDI ; - -M: ppc %unbox-alien ( dst src -- ) - [ v>operand ] bi@ alien-offset LWZ ; - -M: ppc %unbox-f ( dst src -- ) - drop 0 swap v>operand LI ; - -M: ppc %unbox-any-c-ptr ( dst src -- ) - { "is-byte-array" "end" "start" } [ define-label ] each - ! Address is computed in R12 - 0 12 LI - ! Load object into R11 - 11 swap v>operand MR - ! We come back here with displaced aliens - "start" resolve-label - ! Is the object f? - 0 11 f v>operand CMPI - ! If so, done - "end" get BEQ - ! Is the object an alien? - 0 11 header-offset LWZ - 0 0 alien type-number tag-fixnum CMPI - "is-byte-array" get BNE - ! If so, load the offset - 0 11 alien-offset LWZ - ! Add it to address being computed - 12 12 0 ADD - ! Now recurse on the underlying alien - 11 11 underlying-alien-offset LWZ - "start" get B - "is-byte-array" resolve-label - ! Add byte array address to address being computed - 12 12 11 ADD - ! Add an offset to start of byte array's data area - 12 12 byte-array-offset ADDI - "end" resolve-label - ! Done, store address in destination register - v>operand 12 MR ; diff --git a/basis/cpu/ppc/architecture/authors.txt b/basis/cpu/ppc/architecture/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/cpu/ppc/architecture/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/ppc/architecture/summary.txt b/basis/cpu/ppc/architecture/summary.txt deleted file mode 100644 index 76fe694abe..0000000000 --- a/basis/cpu/ppc/architecture/summary.txt +++ /dev/null @@ -1 +0,0 @@ -PowerPC architecture description diff --git a/basis/cpu/ppc/architecture/tags.txt b/basis/cpu/ppc/architecture/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/cpu/ppc/architecture/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/cpu/ppc/intrinsics/authors.txt b/basis/cpu/ppc/intrinsics/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/ppc/intrinsics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor deleted file mode 100644 index 634040b0d0..0000000000 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ /dev/null @@ -1,640 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.accessors alien.c-types arrays -cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot -cpu.architecture kernel kernel.private math math.private -namespaces sequences words generic quotations byte-arrays -hashtables hashtables.private -sequences.private sbufs vectors system layouts -math.floats.private classes slots.private -combinators -compiler.constants -compiler.intrinsics -compiler.generator -compiler.generator.fixup -compiler.generator.registers ; -IN: cpu.ppc.intrinsics - -: %slot-literal-known-tag ( -- out value offset ) - "val" operand - "obj" operand - "n" get cells - "obj" get operand-tag - ; - -: %slot-literal-any-tag ( -- out value offset ) - "obj" operand "scratch1" operand %untag - "val" operand "scratch1" operand "n" get cells ; - -: %slot-any ( -- out value offset ) - "obj" operand "scratch1" operand %untag - "offset" operand "n" operand 1 SRAWI - "scratch1" operand "val" operand "offset" operand ; - -\ slot { - ! Slot number is literal and the tag is known - { - [ %slot-literal-known-tag LWZ ] H{ - { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } } - { +scratch+ { { f "val" } } } - { +output+ { "val" } } - } - } - ! Slot number is literal - { - [ %slot-literal-any-tag LWZ ] H{ - { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch1" } { f "val" } } } - { +output+ { "val" } } - } - } - ! Slot number in a register - { - [ %slot-any LWZX ] H{ - { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } } - { +output+ { "val" } } - } - } -} define-intrinsics - -: load-cards-offset ( dest -- ) - "cards_offset" f pick %load-dlsym dup 0 LWZ ; - -: load-decks-offset ( dest -- ) - "decks_offset" f pick %load-dlsym dup 0 LWZ ; - -: %write-barrier ( -- ) - "val" get operand-immediate? "obj" get fresh-object? or [ - card-mark "scratch1" operand LI - - ! Mark the card - "val" operand load-cards-offset - "obj" operand "scratch2" operand card-bits SRWI - "scratch2" operand "scratch1" operand "val" operand STBX - - ! Mark the card deck - "val" operand load-decks-offset - "obj" operand "scratch2" operand deck-bits SRWI - "scratch2" operand "scratch1" operand "val" operand STBX - ] unless ; - -\ set-slot { - ! Slot number is literal and tag is known - { - [ %slot-literal-known-tag STW %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch1" } { f "scratch2" } } } - { +clobber+ { "val" } } - } - } - ! Slot number is literal - { - [ %slot-literal-any-tag STW %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch1" } { f "scratch2" } } } - { +clobber+ { "val" } } - } - } - ! Slot number is in a register - { - [ %slot-any STWX %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" } { f "n" } } } - { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } } - { +clobber+ { "val" } } - } - } -} define-intrinsics - -: fixnum-register-op ( op -- pair ) - [ "out" operand "y" operand "x" operand ] swap suffix H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } 2array ; - -: fixnum-value-op ( op -- pair ) - [ "out" operand "x" operand "y" operand ] swap suffix H{ - { +input+ { { f "x" } { [ small-tagged? ] "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } 2array ; - -: define-fixnum-op ( word imm-op reg-op -- ) - >r fixnum-value-op r> fixnum-register-op 2array - define-intrinsics ; - -{ - { fixnum+fast ADDI ADD } - { fixnum-fast SUBI SUBF } - { fixnum-bitand ANDI AND } - { fixnum-bitor ORI OR } - { fixnum-bitxor XORI XOR } -} [ - first3 define-fixnum-op -] each - -\ fixnum*fast { - { - [ - "out" operand "x" operand "y" get MULLI - ] H{ - { +input+ { { f "x" } { [ small-tagged? ] "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } - } { - [ - "out" operand "x" operand %untag-fixnum - "out" operand "y" operand "out" operand MULLW - ] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } - } -} define-intrinsics - -: %untag-fixnums ( seq -- ) - [ dup %untag-fixnum ] unique-operands ; - -\ fixnum-shift-fast { - { - [ - "out" operand "x" operand "y" get - dup 0 < [ neg SRAWI ] [ swapd SLWI ] if - ! Mask off low bits - "out" operand dup %untag - ] H{ - { +input+ { { f "x" } { [ ] "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } - } - { - [ - { "positive" "end" } [ define-label ] each - "out" operand "y" operand %untag-fixnum - 0 "y" operand 0 CMPI - "positive" get BGE - "out" operand dup NEG - "out" operand "x" operand "out" operand SRAW - "end" get B - "positive" resolve-label - "out" operand "x" operand "out" operand SLW - "end" resolve-label - ! Mask off low bits - "out" operand dup %untag - ] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } - } -} define-intrinsics - -: generate-fixnum-mod ( -- ) - #! PowerPC doesn't have a MOD instruction; so we compute - #! x-(x/y)*y. Puts the result in "s" operand. - "s" operand "r" operand "y" operand MULLW - "s" operand "s" operand "x" operand SUBF ; - -\ fixnum-mod [ - ! divide x by y, store result in x - "r" operand "x" operand "y" operand DIVW - generate-fixnum-mod -] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "r" } { f "s" } } } - { +output+ { "s" } } -} define-intrinsic - -\ fixnum-bitnot [ - "x" operand dup NOT - "x" operand dup %untag -] H{ - { +input+ { { f "x" } } } - { +output+ { "x" } } -} define-intrinsic - -: fixnum-register-jump ( op -- pair ) - [ "x" operand 0 "y" operand CMP ] swap suffix - { { f "x" } { f "y" } } 2array ; - -: fixnum-value-jump ( op -- pair ) - [ 0 "x" operand "y" operand CMPI ] swap suffix - { { f "x" } { [ small-tagged? ] "y" } } 2array ; - -: define-fixnum-jump ( word op -- ) - [ fixnum-value-jump ] keep fixnum-register-jump - 2array define-if-intrinsics ; - -{ - { fixnum< BGE } - { fixnum<= BGT } - { fixnum> BLE } - { fixnum>= BLT } - { eq? BNE } -} [ - first2 define-fixnum-jump -] each - -: overflow-check ( insn1 insn2 -- ) - [ - >r 0 0 LI - 0 MTXER - "r" operand "y" operand "x" operand r> execute - >r - "end" define-label - "end" get BNO - { "x" "y" } %untag-fixnums - "r" operand "y" operand "x" operand r> execute - "r" get %allot-bignum-signed-1 - "end" resolve-label - ] with-scope ; inline - -: overflow-template ( word insn1 insn2 -- ) - [ overflow-check ] 2curry H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "r" } } } - { +output+ { "r" } } - { +clobber+ { "x" "y" } } - } define-intrinsic ; - -\ fixnum+ \ ADD \ ADDO. overflow-template -\ fixnum- \ SUBF \ SUBFO. overflow-template - -: generate-fixnum/i ( -- ) - #! This VOP is funny. If there is an overflow, it falls - #! through to the end, and the result is in "x" operand. - #! Otherwise it jumps to the "no-overflow" label and the - #! result is in "r" operand. - "end" define-label - "no-overflow" define-label - "r" operand "x" operand "y" operand DIVW - ! if the result is greater than the most positive fixnum, - ! which can only ever happen if we do - ! most-negative-fixnum -1 /i, then the result is a bignum. - most-positive-fixnum "s" operand LOAD - "r" operand 0 "s" operand CMP - "no-overflow" get BLE - most-negative-fixnum neg "x" operand LOAD - "x" get %allot-bignum-signed-1 ; - -\ fixnum/i [ - generate-fixnum/i - "end" get B - "no-overflow" resolve-label - "r" operand "x" operand %tag-fixnum - "end" resolve-label -] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "r" } { f "s" } } } - { +output+ { "x" } } - { +clobber+ { "y" } } -} define-intrinsic - -\ fixnum/mod [ - generate-fixnum/i - 0 "s" operand LI - "end" get B - "no-overflow" resolve-label - generate-fixnum-mod - "r" operand "x" operand %tag-fixnum - "end" resolve-label -] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "r" } { f "s" } } } - { +output+ { "x" "s" } } - { +clobber+ { "y" } } -} define-intrinsic - -\ fixnum>bignum [ - "x" operand dup %untag-fixnum - "x" get %allot-bignum-signed-1 -] H{ - { +input+ { { f "x" } } } - { +output+ { "x" } } -} define-intrinsic - -\ bignum>fixnum [ - "nonzero" define-label - "positive" define-label - "end" define-label - "x" operand dup %untag - "y" operand "x" operand cell LWZ - ! if the length is 1, its just the sign and nothing else, - ! so output 0 - 0 "y" operand 1 v>operand CMPI - "nonzero" get BNE - 0 "y" operand LI - "end" get B - "nonzero" resolve-label - ! load the value - "y" operand "x" operand 3 cells LWZ - ! load the sign - "x" operand "x" operand 2 cells LWZ - ! is the sign negative? - 0 "x" operand 0 CMPI - "positive" get BEQ - "y" operand dup -1 MULI - "positive" resolve-label - "y" operand dup %tag-fixnum - "end" resolve-label -] H{ - { +input+ { { f "x" } } } - { +scratch+ { { f "y" } } } - { +clobber+ { "x" } } - { +output+ { "y" } } -} define-intrinsic - -: define-float-op ( word op -- ) - [ "z" operand "x" operand "y" operand ] swap suffix H{ - { +input+ { { float "x" } { float "y" } } } - { +scratch+ { { float "z" } } } - { +output+ { "z" } } - } define-intrinsic ; - -{ - { float+ FADD } - { float- FSUB } - { float* FMUL } - { float/f FDIV } -} [ - first2 define-float-op -] each - -: define-float-jump ( word op -- ) - [ "x" operand 0 "y" operand FCMPU ] swap suffix - { { float "x" } { float "y" } } define-if-intrinsic ; - -{ - { float< BGE } - { float<= BGT } - { float> BLE } - { float>= BLT } - { float= BNE } -} [ - first2 define-float-jump -] each - -\ float>fixnum [ - "scratch" operand "in" operand FCTIWZ - "scratch" operand 1 0 param@ STFD - "out" operand 1 cell param@ LWZ - "out" operand dup %tag-fixnum -] H{ - { +input+ { { float "in" } } } - { +scratch+ { { float "scratch" } { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ fixnum>float [ - HEX: 4330 "scratch" operand LIS - "scratch" operand 1 0 param@ STW - "scratch" operand "in" operand %untag-fixnum - "scratch" operand dup HEX: 8000 XORIS - "scratch" operand 1 cell param@ STW - "f1" operand 1 0 param@ LFD - 4503601774854144.0 "scratch" operand load-indirect - "f2" operand "scratch" operand float-offset LFD - "f1" operand "f1" operand "f2" operand FSUB -] H{ - { +input+ { { f "in" } } } - { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } } - { +output+ { "f1" } } -} define-intrinsic - - -\ tag [ - "out" operand "in" operand tag-mask get ANDI - "out" operand dup %tag-fixnum -] H{ - { +input+ { { f "in" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -: userenv ( reg -- ) - #! Load the userenv pointer in a register. - "userenv" f rot %load-dlsym ; - -\ getenv [ - "n" operand dup 1 SRAWI - "x" operand userenv - "x" operand "n" operand "x" operand ADD - "x" operand dup 0 LWZ -] H{ - { +input+ { { f "n" } } } - { +scratch+ { { f "x" } } } - { +output+ { "x" } } - { +clobber+ { "n" } } -} define-intrinsic - -\ setenv [ - "n" operand dup 1 SRAWI - "x" operand userenv - "x" operand "n" operand "x" operand ADD - "val" operand "x" operand 0 STW -] H{ - { +input+ { { f "val" } { f "n" } } } - { +scratch+ { { f "x" } } } - { +clobber+ { "n" } } -} define-intrinsic - -\ (tuple) [ - tuple "layout" get size>> 2 + cells %allot - ! Store layout - "layout" get 12 load-indirect - 12 11 cell STW - ! Store tagged ptr in reg - "tuple" get tuple %store-tagged -] H{ - { +input+ { { [ ] "layout" } } } - { +scratch+ { { f "tuple" } } } - { +output+ { "tuple" } } -} define-intrinsic - -\ (array) [ - array "n" get 2 + cells %allot - ! Store length - "n" operand 12 LI - 12 11 cell STW - ! Store tagged ptr in reg - "array" get object %store-tagged -] H{ - { +input+ { { [ ] "n" } } } - { +scratch+ { { f "array" } } } - { +output+ { "array" } } -} define-intrinsic - -\ (byte-array) [ - byte-array "n" get 2 cells + %allot - ! Store length - "n" operand 12 LI - 12 11 cell STW - ! Store tagged ptr in reg - "array" get object %store-tagged -] H{ - { +input+ { { [ ] "n" } } } - { +scratch+ { { f "array" } } } - { +output+ { "array" } } -} define-intrinsic - -\ [ - ratio 3 cells %allot - "numerator" operand 11 1 cells STW - "denominator" operand 11 2 cells STW - ! Store tagged ptr in reg - "ratio" get ratio %store-tagged -] H{ - { +input+ { { f "numerator" } { f "denominator" } } } - { +scratch+ { { f "ratio" } } } - { +output+ { "ratio" } } -} define-intrinsic - -\ [ - complex 3 cells %allot - "real" operand 11 1 cells STW - "imaginary" operand 11 2 cells STW - ! Store tagged ptr in reg - "complex" get complex %store-tagged -] H{ - { +input+ { { f "real" } { f "imaginary" } } } - { +scratch+ { { f "complex" } } } - { +output+ { "complex" } } -} define-intrinsic - -\ [ - wrapper 2 cells %allot - "obj" operand 11 1 cells STW - ! Store tagged ptr in reg - "wrapper" get object %store-tagged -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "wrapper" } } } - { +output+ { "wrapper" } } -} define-intrinsic - -! Alien intrinsics -: %alien-accessor ( quot -- ) - "offset" operand dup %untag-fixnum - "scratch" operand "offset" operand "alien" operand ADD - "value" operand "scratch" operand 0 roll call ; inline - -: alien-integer-get-template - H{ - { +input+ { - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "value" } { f "scratch" } } } - { +output+ { "value" } } - { +clobber+ { "offset" } } - } ; - -: %alien-integer-get ( quot -- ) - %alien-accessor - "value" operand dup %tag-fixnum ; inline - -: alien-integer-set-template - H{ - { +input+ { - { f "value" fixnum } - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "value" "offset" } } - } ; - -: %alien-integer-set ( quot -- ) - "offset" get "value" get = [ - "value" operand dup %untag-fixnum - ] unless - %alien-accessor ; inline - -: define-alien-integer-intrinsics ( word get-quot word set-quot -- ) - [ %alien-integer-set ] curry - alien-integer-set-template - define-intrinsic - [ %alien-integer-get ] curry - alien-integer-get-template - define-intrinsic ; - -\ alien-unsigned-1 [ LBZ ] -\ set-alien-unsigned-1 [ STB ] -define-alien-integer-intrinsics - -\ alien-signed-1 [ pick >r LBZ r> dup EXTSB ] -\ set-alien-signed-1 [ STB ] -define-alien-integer-intrinsics - -\ alien-unsigned-2 [ LHZ ] -\ set-alien-unsigned-2 [ STH ] -define-alien-integer-intrinsics - -\ alien-signed-2 [ LHA ] -\ set-alien-signed-2 [ STH ] -define-alien-integer-intrinsics - -\ alien-cell [ - [ LWZ ] %alien-accessor -] H{ - { +input+ { - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { unboxed-alien "value" } { f "scratch" } } } - { +output+ { "value" } } - { +clobber+ { "offset" } } -} define-intrinsic - -\ set-alien-cell [ - [ STW ] %alien-accessor -] H{ - { +input+ { - { unboxed-c-ptr "value" pinned-c-ptr } - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "offset" } } -} define-intrinsic - -: alien-float-get-template - H{ - { +input+ { - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { float "value" } { f "scratch" } } } - { +output+ { "value" } } - { +clobber+ { "offset" } } - } ; - -: alien-float-set-template - H{ - { +input+ { - { float "value" float } - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "offset" } } - } ; - -: define-alien-float-intrinsics ( word get-quot word set-quot -- ) - [ %alien-accessor ] curry - alien-float-set-template - define-intrinsic - [ %alien-accessor ] curry - alien-float-get-template - define-intrinsic ; - -\ alien-double [ LFD ] -\ set-alien-double [ STFD ] -define-alien-float-intrinsics - -\ alien-float [ LFS ] -\ set-alien-float [ STFS ] -define-alien-float-intrinsics diff --git a/basis/cpu/ppc/intrinsics/tags.txt b/basis/cpu/ppc/intrinsics/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/cpu/ppc/intrinsics/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 1577945118..8e7d8fed7d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,8 +1,15 @@ -USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics -cpu.architecture namespaces alien.c-types kernel system -combinators ; +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: cpu.ppc.architecture -{ +! PowerPC register assignments +! r3-r11, r16-r31: integer vregs +! f0-f13: float vregs +! r12: scratch +! r14: data stack +! r15: retain stack + +<< { { [ os macosx? ] [ 4 "longlong" c-type (>>align) 4 "ulonglong" c-type (>>align) @@ -12,4 +19,545 @@ combinators ; t "longlong" c-type (>>stack-align?) t "ulonglong" c-type (>>stack-align?) ] } -} cond +} cond >> + +M: ppc machine-registers + { + { int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } } + { double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } } + } ; + +: scratch-reg 12 ; inline + +M: ppc two-operand? t ; + +M: ppc %load-immediate ( reg n -- ) swap LOAD ; + +M:: ppc %load-indirect ( reg obj -- ) + 0 reg LOAD32 + obj rc-absolute-ppc-2/2 rel-literal + reg reg 0 LWZ ; + +: ds-reg 14 ; inline +: rs-reg 15 ; inline + +GENERIC: loc-reg ( loc -- reg ) + +M: ds-loc log-reg drop ds-reg ; +M: rs-loc log-reg drop rs-reg ; + +: loc>operand ( loc -- reg n ) + [ loc-reg ] [ n>> cells neg ] bi ; inline + +M: ppc %peek loc>operand LWZ ; +M: ppc %replace loc>operand STW ; + +: (%inc) ( n reg -- ) dup rot cells ADDI ; inline + +M: ppc %inc-d ( n -- ) ds-reg (%inc) ; +M: ppc %inc-r ( n -- ) rs-reg (%inc) ; + +: reserved-area-size ( -- n ) + os { + { linux [ 2 ] } + { macosx [ 6 ] } + } case cells ; foldable + +: lr-save ( -- n ) + os { + { linux [ 1 ] } + { macosx [ 2 ] } + } case cells ; foldable + +: param@ ( n -- x ) reserved-area-size + ; inline + +: param-save-size ( -- n ) 8 cells ; foldable + +: local@ ( n -- x ) + reserved-area-size param-save-size + + ; inline + +: factor-area-size ( -- n ) 2 cells ; foldable + +: next-save ( n -- i ) cell - ; + +: xt-save ( n -- i ) 2 cells - ; + +M: ppc stack-frame-size ( stack-frame -- i ) + local@ factor-area-size + 4 cells align ; + +! M: x86 stack-frame-size ( stack-frame -- i ) +! [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] +! [ params>> ] +! [ return>> ] +! tri + + +! 3 cells + +! align-stack ; + +M: ppc %call ( label -- ) BL ; +M: ppc %jump-label ( label -- ) B ; +M: ppc %return ( -- ) BLR ; + +M:: ppc %dispatch ( src temp -- ) + 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here + temp temp src ADD + temp temp 5 cells LWZ + temp MTCTR + BCTR ; + +M: ppc %dispatch-label ( word -- ) + 0 , rc-absolute-cell rel-word ; + +:: (%slot) ( obj slot tag temp -- reg offset ) + temp slot obj ADD + temp tag neg ; inline + +: (%slot-imm) ( obj slot tag -- reg offset ) + [ cells ] dip - ; inline + +M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ; +M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ; +M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ; +M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ; + +M: ppc %add ADD ; +M: ppc %add-imm ADDI ; +M: ppc %sub swapd SUBF ; +M: ppc %sub-imm SUBI ; +M: ppc %mul MULLW ; +M: ppc %mul-imm MULLI ; +M: ppc %and AND ; +M: ppc %and-imm ANDI ; +M: ppc %or OR ; +M: ppc %or-imm ORI ; +M: ppc %xor XOR ; +M: ppc %xor-imm XORI ; +M: ppc %shl-imm swapd SLWI ; +M: ppc %shr-imm swapd SRWI ; +M: ppc %sar-imm SRAWI ; +M: ppc %not NOT ; + +M: ppc %integer>bignum ( dst src temp -- ) + [ + { "end" "non-zero" "pos" "store" } [ define-label ] each + ! is it zero? + 0 over v>operand 0 CMPI + "non-zero" get BNE + dup 0 >bignum %load-literal + "end" get B + ! it is non-zero + "non-zero" resolve-label + 1 bignum over 3 + cells %allot + 1+ v>operand 12 LI ! compute the length + 12 11 cell STW ! store the length + ! is the fixnum negative? + 0 over v>operand 0 CMPI + "pos" get BGE + 1 12 LI + ! store negative sign + 12 11 2 cells STW + ! negate fixnum + dup v>operand dup -1 MULI + "store" get B + "pos" resolve-label + 0 12 LI + ! store positive sign + 12 11 2 cells STW + "store" resolve-label + ! store the number + dup v>operand 11 3 cells STW + ! tag the bignum, store it in reg + bignum %store-tagged + "end" resolve-label + ] with-scope ; + +: bignum@ ( n -- offset ) cells bignum tag-number - ; inline + +M:: %bignum>integer ( dst src -- ) + [ + "end" define-label + scratch-reg src 1 bignum@ LWZ + ! if the length is 1, its just the sign and nothing else, + ! so output 0 + 0 dst LI + 0 scratch-reg 1 v>operand CMPI + "end" get BEQ + ! load the value + dst src 3 bignum@ LWZ + ! load the sign + scratch-reg src 2 bignum@ LWZ + ! branchless arithmetic: we want to turn 0 into 1, + ! and 1 into -1 + scratch-reg scratch-reg 1 SLWI + scratch-reg scratch-reg NEG + scratch-reg scratch-reg 1 ADDI + ! multiply value by sign + dst dst scratch-reg MULLW + "end" resolve-label + ] with-scope ; + +M: ppc %add-float FADD ; +M: ppc %sub-float FSUB ; +M: ppc %mul-float FMUL ; +M: ppc %div-float FDIV ; + +M: ppc %integer>float + HEX: 4330 "scratch" operand LIS + "scratch" operand 1 0 param@ STW + "in" operand dup HEX: 8000 XORIS + "in" operand 1 cell param@ STW + "f1" operand 1 0 param@ LFD + 4503601774854144.0 "in" operand load-indirect + "f2" operand "in" operand float-offset LFD + "f1" operand "f1" operand "f2" operand FSUB ; + +M: ppc %float>integer + "scratch" operand "in" operand FCTIWZ + "scratch" operand 1 0 param@ STFD + "out" operand 1 cell param@ LWZ ; + +M: ppc %copy ( dst src -- ) MR ; + +M: ppc %copy-float ( dst src -- ) MFR ; + +M: ppc %unbox-float ( dst src -- ) float-offset LFD ; + +M:: ppc %unbox-any-c-ptr ( dst src temp -- ) + [ + { "is-byte-array" "end" "start" } [ define-label ] each + ! Address is computed in dst + 0 dst LI + ! Load object into scratch-reg + scratch-reg src MR + ! We come back here with displaced aliens + "start" resolve-label + ! Is the object f? + 0 scratch-reg \ f tag-number CMPI + ! If so, done + "end" get BEQ + ! Is the object an alien? + 0 scratch-reg header-offset LWZ + 0 0 alien type-number tag-fixnum CMPI + "is-byte-array" get BNE + ! If so, load the offset + 0 scratch-reg alien-offset LWZ + ! Add it to address being computed + dst dst 0 ADD + ! Now recurse on the underlying alien + scratch-reg scratch-reg underlying-alien-offset LWZ + "start" get B + "is-byte-array" resolve-label + ! Add byte array address to address being computed + dst dst scratch-reg ADD + ! Add an offset to start of byte array's data area + dst dst byte-array-offset ADDI + "end" resolve-label + ] with-scope ; + +: alien@ ( n -- n' ) cells object tag-number - ; + +M:: ppc %box-alien ( dst src temp -- ) + [ + "f" define-label + dst \ f tag-number %load-immediate + 0 src 0 CMPI + "f" get BEQ + dst 4 cells alien temp %allot + ! Store offset + dst src 3 alien@ STW + temp \ f tag-number %load-immediate + ! Store expired slot + temp dst 1 alien@ STW + ! Store underlying-alien slot + temp dst 2 alien@ STW + "f" resolve-label + ] with-scope ; + +M: ppc %alien-unsigned-1 0 LBZ ; +M: ppc %alien-unsigned-2 0 LHZ ; + +M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ; +M: ppc %alien-signed-2 0 LHA ; + +M: ppc %alien-cell 0 LWZ ; + +M: ppc %alien-float 0 LFS ; +M: ppc %alien-double 0 LFD ; + +M: ppc %set-alien-integer-1 0 STB ; +M: ppc %set-alien-integer-2 0 STH ; + +M: ppc %set-alien-cell 0 STW ; + +M: ppc %set-alien-float 0 STFS ; +M: ppc %set-alien-double 0 STFD ; + +: load-zone-ptr ( reg -- ) + [ "nursery" f ] dip %load-dlsym ; + +: load-allot-ptr ( nursery-ptr allot-ptr -- ) + [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ; + +:: inc-allot-ptr ( nursery-ptr n -- ) + scratch-reg inc-allot-ptr 4 LWZ + scratch-reg scratch-reg n 8 align ADD + scratch-reg inc-allot-ptr 4 STW ; + +:: store-header ( temp class -- ) + class type-number tag-fixnum scratch-reg LI + temp scratch-reg 0 STW ; + +: store-tagged ( dst tag -- ) + dupd tag-number ORI ; + +M:: ppc %allot ( dst size class nursery-ptr -- ) + nursery-ptr dst load-allot-ptr + dst class store-header + dst class store-tagged + nursery-ptr size inc-allot-ptr ; + +: %alien-global ( dest name -- ) + [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ; + +: load-cards-offset ( dest -- ) + "cards_offset" %alien-global ; + +: load-decks-offset ( dest -- ) + "decks_offset" %alien-global ; + +M:: ppc %write-barrier ( src card# table -- ) + card-mark scratch-reg LI + + ! Mark the card + table load-cards-offset + src card# card-bits SRWI + table scratch-reg card# STBX + + ! Mark the card deck + table load-decks-offset + src card# deck-bits SRWI + table scratch-reg card# STBX ; + +M: ppc %gc + "end" define-label + 12 load-zone-ptr + 11 12 cell LWZ ! nursery.here -> r11 + 12 12 3 cells LWZ ! nursery.end -> r12 + 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + 11 0 12 CMP ! is here >= end? + "end" get BLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + +M: ppc %prologue ( n -- ) + 0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this + 0 MFLR + 1 1 pick neg ADDI + scrach-reg 1 pick xt-save STW + dup scrach-reg LI + scrach-reg 1 pick next-save STW + 0 1 rot lr-save + STW ; + +M: ppc %epilogue ( n -- ) + #! At the end of each word that calls a subroutine, we store + #! the previous link register value in r0 by popping it off + #! the stack, set the link register to the contents of r0, + #! and jump to the link register. + 0 1 pick lr-save + LWZ + 1 1 rot ADDI + 0 MTLR ; + +:: (%boolean) ( dst word -- ) + "end" define-label + \ f tag-number %load-immediate + "end" get word execute + dst \ t %load-indirect + "end" get resolve-label ; inline + +: %boolean ( dst cc -- ) + negate-cc { + { cc< [ \ BLT %boolean ] } + { cc<= [ \ BLE %boolean ] } + { cc> [ \ BGT %boolean ] } + { cc>= [ \ BGE %boolean ] } + { cc= [ \ BEQ %boolean ] } + { cc/= [ \ BNE %boolean ] } + } case ; + +: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline +: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline +: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline + +M: ppc %compare (%compare) %boolean ; +M: ppc %compare-imm (%compare-imm) %boolean ; +M: ppc %compare-float (%compare-float) %boolean ; + +: %branch ( label cc -- ) + { + { cc< [ BLT ] } + { cc<= [ BLE ] } + { cc> [ BGT ] } + { cc>= [ BGE ] } + { cc= [ BEQ ] } + { cc/= [ BNE ] } + } case ; + +M: ppc %compare-branch (%compare) %branch ; +M: ppc %compare-imm-branch (%compare-imm) %branch ; +M: ppc %compare-float-branch (%compare-float) %branch ; + +! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ; +! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ; +! +! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ; +! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ; + +M: ppc %loop-entry ; + +M: int-regs return-reg drop 3 ; +M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ; +M: float-regs return-reg drop 1 ; +M: float-regs param-regs + drop os H{ + { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } + { linux { 1 2 3 4 5 6 7 8 } } + } at ; + +M: int-regs %save-param-reg drop 1 rot local@ STW ; +M: int-regs %load-param-reg drop 1 rot local@ LWZ ; + +GENERIC: STF ( src dst off reg-class -- ) + +M: single-float-regs STF drop STFS ; +M: double-float-regs STF drop STFD ; + +M: float-regs %save-param-reg >r 1 rot local@ r> STF ; + +GENERIC: LF ( dst src off reg-class -- ) + +M: single-float-regs LF drop LFS ; +M: double-float-regs LF drop LFD ; + +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 get total-size>> + ; + +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 next-param@ LWZ + 0 1 rot local@ STW ; + +M: ppc %prepare-unbox ( -- ) + ! First parameter is top of stack + 3 ds-reg 0 LWZ + ds-reg dup cell SUBI ; + +M: ppc %unbox ( n reg-class func -- ) + ! Value must be in r3 + ! Call the unboxer + f %alien-invoke + ! Store the return value on the C stack + over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; + +M: ppc %unbox-long-long ( n func -- ) + ! Value must be in r3:r4 + ! Call the unboxer + f %alien-invoke + ! Store the return value on the C stack + [ + 3 1 pick local@ STW + 4 1 rot cell + local@ STW + ] when* ; + +M: ppc %unbox-large-struct ( n c-type -- ) + ! Value must be in r3 + ! 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 ; + +M: ppc %box ( n reg-class func -- ) + ! If the source is a stack location, load it into freg #0. + ! If the source is f, then we assume the value is already in + ! freg #0. + >r + over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if + r> f %alien-invoke ; + +M: ppc %box-long-long ( n func -- ) + >r [ + 3 1 pick local@ LWZ + 4 1 rot cell + local@ LWZ + ] when* r> f %alien-invoke ; + +: struct-return@ ( n -- n ) + [ stack-frame get params>> ] unless* local@ ; + +M: ppc %prepare-box-struct ( -- ) + #! Compute target address for value struct return + 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 + ! Compute destination address and load struct size + [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi* + ! Call the function + "box_value_struct" f %alien-invoke ; + +M: ppc %prepare-alien-invoke + #! Save Factor stack pointers in case the C code calls a + #! callback which does a GC, which must reliably trace + #! all roots. + "stack_chain" f 11 %load-dlsym + 11 11 0 LWZ + 1 11 0 STW + ds-reg 11 8 STW + rs-reg 11 12 STW ; + +M: ppc %alien-invoke ( symbol dll -- ) + 11 %load-dlsym 11 MTLR BLRL ; + +M: ppc %alien-callback ( quot -- ) + 3 load-indirect "c_to_factor" f %alien-invoke ; + +M: ppc %prepare-alien-indirect ( -- ) + "unbox_alien" f %alien-invoke + 13 3 MR ; + +M: ppc %alien-indirect ( -- ) + 13 MTLR BLRL ; + +M: ppc %callback-value ( ctype -- ) + ! Save top of data stack + 3 ds-reg 0 LWZ + 3 1 0 local@ STW + ! Restore data/call/retain stacks + "unnest_stacks" f %alien-invoke + ! Restore top of data stack + 3 1 0 local@ LWZ + ! Unbox former top of data stack to return registers + unbox-return ; + +M: ppc value-structs? + #! On Linux/PPC, value structs are passed in the same way + #! as reference structs, we just have to make a copy first. + os linux? not ; + +M: ppc fp-shadows-int? ( -- ? ) os macosx? ; + +M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; + +M: ppc struct-small-enough? ( size -- ? ) drop f ; + +M: ppc %box-small-struct + drop "No small structs" throw ; + +M: ppc %unbox-small-struct + drop "No small structs" throw ; From 8b7c47a68b992b67cabd1c4141cbd47991c9e80a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:15:48 -0600 Subject: [PATCH 04/12] Clean up x86 backend: move cpu.x86.architecture to cpu.x86, use branchless arithmetic in some intrinsics --- basis/cpu/x86/32/32.factor | 2 +- basis/cpu/x86/64/64.factor | 2 +- basis/cpu/x86/architecture/authors.txt | 1 - basis/cpu/x86/architecture/tags.txt | 1 - basis/cpu/x86/bootstrap.factor | 10 +-- .../architecture.factor => x86.factor} | 84 ++++++++++--------- 6 files changed, 48 insertions(+), 52 deletions(-) delete mode 100755 basis/cpu/x86/architecture/authors.txt delete mode 100644 basis/cpu/x86/architecture/tags.txt rename basis/cpu/x86/{architecture/architecture.factor => x86.factor} (91%) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0e4107eaee..890938c6b3 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -3,7 +3,7 @@ USING: locals alien.c-types alien.syntax arrays kernel math namespaces sequences system layouts io vocabs.loader accessors init combinators command-line cpu.x86.assembler -cpu.x86.architecture cpu.architecture compiler compiler.units +cpu.x86 cpu.architecture compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 3b0403a07e..16e7319c03 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -3,7 +3,7 @@ USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs slots splitting assocs combinators cpu.x86.assembler -cpu.x86.architecture cpu.architecture compiler.constants +cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics ; diff --git a/basis/cpu/x86/architecture/authors.txt b/basis/cpu/x86/architecture/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/x86/architecture/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/x86/architecture/tags.txt b/basis/cpu/x86/architecture/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/cpu/x86/architecture/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index c7c4d0de52..d2ff9a5928 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -271,9 +271,7 @@ big-endian off : jit-math ( insn -- ) arg0 ds-reg [] MOV ! load second input ds-reg bootstrap-cell SUB ! pop stack - arg1 ds-reg [] MOV ! load first input - [ arg1 arg0 ] dip execute ! compute result - ds-reg [] arg1 MOV ! push result + [ ds-reg [] arg0 ] dip execute ! compute result ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive @@ -296,10 +294,8 @@ big-endian off [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive [ - arg0 ds-reg [] MOV ! load input input - arg0 NOT ! complement - arg0 tag-mask get XOR ! clear tag bits - ds-reg [] arg0 MOV ! save + ds-reg [] NOT ! complement + ds-reg [] tag-mask get XOR ! clear tag bits ] f f f \ fixnum-bitnot define-sub-primitive [ diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/x86.factor similarity index 91% rename from basis/cpu/x86/architecture/architecture.factor rename to basis/cpu/x86/x86.factor index 74b8818d16..83c9ee7f0d 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/x86.factor @@ -7,7 +7,7 @@ words system layouts combinators math.order fry locals compiler.constants compiler.cfg.registers compiler.cfg.instructions compiler.codegen compiler.codegen.fixup ; -IN: cpu.x86.architecture +IN: cpu.x86 M: x86 two-operand? t ; @@ -111,49 +111,54 @@ M:: x86 %integer>bignum ( dst src temp -- ) #! 1 cell header, 1 cell length, 1 cell sign, + digits #! length is the # of digits + sign [ - { "end" "nonzero" "positive" } [ define-label ] each - src 0 CMP ! is it zero? - "nonzero" get JNE - ! Use cached zero value + "end" define-label + ! Load cached zero value dst 0 >bignum %load-indirect - "end" get JMP - "nonzero" resolve-label + src 0 CMP + ! Is it zero? Then just go to the end and return this zero + "end" get JE ! Allocate a bignum dst 4 cells bignum temp %allot ! Write length dst 1 bignum@ 2 tag-fixnum MOV - ! Test sign - src 0 CMP - "positive" get JGE - dst 2 bignum@ 1 MOV ! negative sign - src NEG - dst 3 bignum@ src MOV - src NEG ! we don't want to clobber src - "end" get JMP - "positive" resolve-label - dst 2 bignum@ 0 MOV ! positive sign + ! Store value dst 3 bignum@ src MOV + ! Compute sign + temp src MOV + temp cell-bits 1- SAR + temp 1 AND + ! Store sign + dst 2 bignum@ temp MOV + ! Make negative value positive + temp temp ADD + temp NEG + temp 1 ADD + src temp IMUL2 + ! Store the bignum + dst 3 bignum@ temp MOV "end" resolve-label ] with-scope ; -M:: x86 %bignum>integer ( dst src -- ) +M:: x86 %bignum>integer ( dst src temp -- ) [ - "nonzero" define-label "end" define-label - dst src 1 bignum@ MOV - ! if the length is 1, its just the sign and nothing else, - ! so output 0 - dst 1 tag-fixnum CMP - "nonzero" get JNE + ! load length + temp src 1 bignum@ MOV + ! if the length is 1, its just the sign and nothing else, + ! so output 0 dst 0 MOV - "end" get JMP - "nonzero" resolve-label + temp 1 tag-fixnum CMP + "end" get JE ! load the value dst src 3 bignum@ MOV - ! is the sign negative? - src 2 bignum@ 0 CMP - "end" get JE - dst NEG + ! load the sign + temp src 2 bignum@ MOV + ! convert it into -1 or 1 + temp temp ADD + temp NEG + temp 1 ADD + ! make dst signed + temp dst IMUL2 "end" resolve-label ] with-scope ; @@ -206,21 +211,19 @@ M:: x86 %box-float ( dst src temp -- ) dst 16 float temp %allot dst float-offset [+] src MOVSD ; -: alien@ ( reg n -- op ) cells object tag-number - [+] ; +: alien@ ( reg n -- op ) cells alien tag-number - [+] ; M:: x86 %box-alien ( dst src temp -- ) [ - { "end" "f" } [ define-label ] each + "end" define-label + dst \ f tag-number MOV src 0 CMP - "f" get JE + "end" get JE dst 4 cells alien temp %allot dst 1 alien@ \ f tag-number MOV dst 2 alien@ \ f tag-number MOV ! Store src in alien-offset slot dst 3 alien@ src MOV - "end" get JMP - "f" resolve-label - dst \ f tag-number MOV "end" resolve-label ] with-scope ; @@ -339,7 +342,7 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ; : inc-allot-ptr ( nursery-ptr n -- ) [ cell [+] ] dip 8 align ADD ; -: store-header ( temp type -- ) +: store-header ( temp class -- ) [ [] ] [ type-number tag-fixnum ] bi* MOV ; : store-tagged ( dst tag -- ) @@ -463,11 +466,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ; M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ; -M: x86 %spill-float spill-float@ swap MOVSD ; -M: x86 %reload-float spill-float@ MOVSD ; +M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ; +M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; -M: x86 %loop-entry - 16 code-alignment [ NOP ] times ; +M: x86 %loop-entry 16 code-alignment [ NOP ] times ; M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ; From dae41147fe32b4555440ea7ecf3c71dc0520cbc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:16:08 -0600 Subject: [PATCH 05/12] %bignum>integer now takes a temporary register since this is useful on both x86 and ppc --- basis/compiler/codegen/codegen.factor | 2 +- basis/cpu/architecture/architecture.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7dca752cf7..0d36a88b45 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -152,7 +152,7 @@ M: ##not generate-insn dst/src %not ; [ dst/src ] [ temp>> register ] bi ; inline M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ; -M: ##bignum>integer generate-insn dst/src %bignum>integer ; +M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ; M: ##add-float generate-insn dst/src1/src2 %add-float ; M: ##sub-float generate-insn dst/src1/src2 %sub-float ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 618be9a11f..c86f236976 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -76,7 +76,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) HOOK: %integer>bignum cpu ( dst src temp -- ) -HOOK: %bignum>integer cpu ( dst src -- ) +HOOK: %bignum>integer cpu ( dst src temp -- ) HOOK: %add-float cpu ( dst src1 src2 -- ) HOOK: %sub-float cpu ( dst src1 src2 -- ) From 7aa530c64efff9edaa9aa4643e41cd32db201893 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:16:15 -0600 Subject: [PATCH 06/12] Fix ABOUT: docs --- basis/help/help-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 643e121f5e..2fe4edfe7f 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -407,7 +407,7 @@ HELP: ARTICLE: } ; HELP: ABOUT: -{ $syntax "MAIN: article" } +{ $syntax "ABOUT: article" } { $values { "article" "a help article" } } { $description "Defines the main documentation article for the current vocabulary." } ; From 2239f4fb9958c1e6973a11eb4291cae38e97890e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:20:35 -0600 Subject: [PATCH 07/12] More work on PowerPC backend; change register usage, free up some more integer and float regs (untested) --- basis/cpu/ppc/bootstrap.factor | 4 +- basis/cpu/ppc/ppc.factor | 191 ++++++++++++++++----------- vm/cpu-ppc.S | 233 ++++++++++++++++++++------------- vm/cpu-ppc.h | 4 +- 4 files changed, 256 insertions(+), 176 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 47c31111a9..7d5e359a80 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -11,8 +11,8 @@ big-endian on 4 jit-code-format set -: ds-reg 14 ; -: rs-reg 15 ; +: ds-reg 30 ; +: rs-reg 31 ; : factor-area-size ( -- n ) 4 bootstrap-cells ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 8e7d8fed7d..0857c4405c 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,13 +1,30 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: cpu.ppc.architecture +USING: alien.c-types +accessors +cpu.architecture +compiler.cfg.registers +cpu.ppc.assembler +kernel +locals +layouts +combinators +make +compiler.cfg.instructions +math.order +system +math +compiler.constants +namespaces compiler.codegen.fixup ; +IN: cpu.ppc -! PowerPC register assignments -! r3-r11, r16-r31: integer vregs -! f0-f13: float vregs -! r12: scratch -! r14: data stack -! r15: retain stack +! PowerPC register assignments: +! r2-r28: integer vregs +! r29: integer scratch +! r30: data stack +! r31: retain stack +! f0-f29: float vregs +! f30, f31: float scratch << { { [ os macosx? ] [ @@ -23,13 +40,15 @@ IN: cpu.ppc.architecture M: ppc machine-registers { - { int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } } - { double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } } + { int-regs T{ range f 2 27 1 } } + { double-float-regs T{ range f 0 28 1 } } } ; -: scratch-reg 12 ; inline +: scratch-reg 29 ; inline +: fp-scratch-reg-1 30 ; inline +: fp-scratch-reg-2 31 ; inline -M: ppc two-operand? t ; +M: ppc two-operand? f ; M: ppc %load-immediate ( reg n -- ) swap LOAD ; @@ -38,8 +57,8 @@ M:: ppc %load-indirect ( reg obj -- ) obj rc-absolute-ppc-2/2 rel-literal reg reg 0 LWZ ; -: ds-reg 14 ; inline -: rs-reg 15 ; inline +: ds-reg 30 ; inline +: rs-reg 31 ; inline GENERIC: loc-reg ( loc -- reg ) @@ -83,15 +102,14 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ; : xt-save ( n -- i ) 2 cells - ; M: ppc stack-frame-size ( stack-frame -- i ) - local@ factor-area-size + 4 cells align ; - -! M: x86 stack-frame-size ( stack-frame -- i ) -! [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] -! [ params>> ] -! [ return>> ] -! tri + + -! 3 cells + -! align-stack ; + [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] + [ params>> ] + [ return>> ] + tri + + + reserved-area-size + + param-save-size + + factor-area-size + + 4 cells align ; M: ppc %call ( label -- ) BL ; M: ppc %jump-label ( label -- ) B ; @@ -136,62 +154,57 @@ M: ppc %shr-imm swapd SRWI ; M: ppc %sar-imm SRAWI ; M: ppc %not NOT ; +: bignum@ ( n -- offset ) cells bignum tag-number - ; inline + M: ppc %integer>bignum ( dst src temp -- ) [ { "end" "non-zero" "pos" "store" } [ define-label ] each - ! is it zero? - 0 over v>operand 0 CMPI - "non-zero" get BNE - dup 0 >bignum %load-literal - "end" get B - ! it is non-zero - "non-zero" resolve-label - 1 bignum over 3 + cells %allot - 1+ v>operand 12 LI ! compute the length - 12 11 cell STW ! store the length - ! is the fixnum negative? - 0 over v>operand 0 CMPI - "pos" get BGE - 1 12 LI - ! store negative sign - 12 11 2 cells STW - ! negate fixnum - dup v>operand dup -1 MULI - "store" get B - "pos" resolve-label - 0 12 LI - ! store positive sign - 12 11 2 cells STW - "store" resolve-label - ! store the number - dup v>operand 11 3 cells STW - ! tag the bignum, store it in reg - bignum %store-tagged + dst 0 >bignum %load-immediate + ! Is it zero? Then just go to the end and return this zero + 0 src 0 CMPI + "end" get BEQ + ! Allocate a bignum + dst 4 cells bignum temp %allot + ! Write length + 2 temp LI + dst 1 bignum@ temp STW + ! Store value + dst 3 bignum@ src STW + ! Compute sign + temp src MR + temp cell-bits 1- SRAWI + temp temp 1 ANDI + ! Store sign + dst 2 bignum@ temp STW + ! Make negative value positive + temp temp temp ADD + temp temp NEG + temp temp 1 ADDI + temp src temp MULLW + ! Store the bignum + dst 3 bignum@ temp STW "end" resolve-label ] with-scope ; -: bignum@ ( n -- offset ) cells bignum tag-number - ; inline - -M:: %bignum>integer ( dst src -- ) +M:: %bignum>integer ( dst src temp -- ) [ "end" define-label - scratch-reg src 1 bignum@ LWZ + temp src 1 bignum@ LWZ ! if the length is 1, its just the sign and nothing else, ! so output 0 0 dst LI - 0 scratch-reg 1 v>operand CMPI + 0 temp 1 v>operand CMPI "end" get BEQ ! load the value dst src 3 bignum@ LWZ ! load the sign - scratch-reg src 2 bignum@ LWZ + temp src 2 bignum@ LWZ ! branchless arithmetic: we want to turn 0 into 1, ! and 1 into -1 - scratch-reg scratch-reg 1 SLWI - scratch-reg scratch-reg NEG - scratch-reg scratch-reg 1 ADDI + temp temp temp ADD + temp temp 1 SUBI ! multiply value by sign - dst dst scratch-reg MULLW + dst dst temp MULLW "end" resolve-label ] with-scope ; @@ -200,20 +213,21 @@ M: ppc %sub-float FSUB ; M: ppc %mul-float FMUL ; M: ppc %div-float FDIV ; -M: ppc %integer>float - HEX: 4330 "scratch" operand LIS - "scratch" operand 1 0 param@ STW - "in" operand dup HEX: 8000 XORIS - "in" operand 1 cell param@ STW - "f1" operand 1 0 param@ LFD - 4503601774854144.0 "in" operand load-indirect - "f2" operand "in" operand float-offset LFD - "f1" operand "f1" operand "f2" operand FSUB ; +M: ppc %integer>float ( dst src -- ) + HEX: 4330 scratch-reg LIS + scratch-reg 1 0 param@ STW + scratch-reg src MR + scratch-reg dup HEX: 8000 XORIS + scratch-reg 1 cell param@ STW + fp-scratch-reg-2 1 0 param@ LFD + 4503601774854144.0 scratch-reg load-indirect + fp-scratch-reg-2 scratch-reg float-offset LFD + fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ; -M: ppc %float>integer - "scratch" operand "in" operand FCTIWZ - "scratch" operand 1 0 param@ STFD - "out" operand 1 cell param@ LWZ ; +M:: ppc %float>integer ( dst src -- ) + fp-scratch-reg-1 src FCTIWZ + fp-scratch-reg-2 1 0 param@ STFD + dst 1 4 param@ LWZ ; M: ppc %copy ( dst src -- ) MR ; @@ -407,11 +421,32 @@ M: ppc %compare-branch (%compare) %branch ; M: ppc %compare-imm-branch (%compare-imm) %branch ; M: ppc %compare-float-branch (%compare-float) %branch ; -! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ; -! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ; -! -! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ; -! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ; +: spill-integer-base ( stack-frame -- n ) + [ params>> ] [ return>> ] bi + ; + +: stack@ 1 swap ; inline + +: spill-integer@ ( n -- op ) + cells + stack-frame get spill-integer-base + + stack@ ; + +: spill-float-base ( stack-frame -- n ) + [ spill-counts>> int-regs swap at int-regs reg-size * ] + [ params>> ] + [ return>> ] + tri + + ; + +: spill-float@ ( n -- op ) + double-float-regs reg-size * + stack-frame get spill-float-base + + stack@ ; + +M: ppc %spill-integer ( src n -- ) spill-integer@ STW ; +M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ; + +M: ppc %spill-float ( src n -- ) spill-float@ STFD ; +M: ppc %reload-float ( dst n -- ) spill-float@ LFD ; M: ppc %loop-entry ; diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 412e277ea6..9fadc5df4a 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -4,30 +4,32 @@ in the public domain. */ /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,9(r3) /* load quotation-xt slot */ XX \ + lwz r11,9(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtlr r11 /* prepare to call XT with quotation in r3 */ XX \ - blrl /* go */ + CALL_OR_JUMP_QUOT XX \ + mtlr r11 /* prepare to call XT with quotation in r3 */ XX \ + blrl /* go */ #define JUMP_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtctr r11 /* prepare to call XT with quotation in r3 */ XX \ - bctr /* go */ + CALL_OR_JUMP_QUOT XX \ + mtctr r11 /* prepare to call XT with quotation in r3 */ XX \ + bctr /* go */ #define PARAM_SIZE 32 -#define SAVED_REGS_SIZE 96 +#define SAVED_INT_REGS_SIZE 96 -#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_REGS_SIZE + 8) +#define SAVED_FP_REGS_SIZE 144 + +#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8) #if defined( __APPLE__) - #define LR_SAVE 8 - #define RESERVED_SIZE 24 + #define LR_SAVE 8 + #define RESERVED_SIZE 24 #else - #define LR_SAVE 4 - #define RESERVED_SIZE 8 + #define LR_SAVE 4 + #define RESERVED_SIZE 8 #endif #define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1) @@ -36,99 +38,142 @@ in the public domain. */ #define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset) -#define SAVE(register,offset) stw register,SAVE_AT(offset)(r1) +#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1) +#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1) -#define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1) +#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1) +#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) #define PROLOGUE \ - mflr r0 XX /* get caller's return address */ \ - stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ - SAVE_LR(r0) + mflr r0 XX /* get caller's return address */ \ + stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ + SAVE_LR(r0) #define EPILOGUE \ LOAD_LR(r0) XX \ - lwz r1,0(r1) XX /* destroy the stack frame */ \ - mtlr r0 /* get ready to return */ + lwz r1,0(r1) XX /* destroy the stack frame */ \ + mtlr r0 /* get ready to return */ +/* We have to save and restore nonvolatile registers because +the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): - PROLOGUE + PROLOGUE - SAVE(r13,0) /* save GPRs */ - /* don't save ds pointer */ - /* don't save rs pointer */ - SAVE(r16,3) - SAVE(r17,4) - SAVE(r18,5) - SAVE(r19,6) - SAVE(r20,7) - SAVE(r21,8) - SAVE(r22,9) - SAVE(r23,10) - SAVE(r24,11) - SAVE(r25,12) - SAVE(r26,13) - SAVE(r27,14) - SAVE(r28,15) - SAVE(r29,16) - SAVE(r30,17) - SAVE(r31,18) - SAVE(r3,19) /* save quotation since we're about to mangle it */ + SAVE_INT(r13,0) /* save GPRs */ + /* don't save ds pointer */ + /* don't save rs pointer */ + SAVE_INT(r16,3) + SAVE_INT(r17,4) + SAVE_INT(r18,5) + SAVE_INT(r19,6) + SAVE_INT(r20,7) + SAVE_INT(r21,8) + SAVE_INT(r22,9) + SAVE_INT(r23,10) + SAVE_INT(r24,11) + SAVE_INT(r25,12) + SAVE_INT(r26,13) + SAVE_INT(r27,14) + SAVE_INT(r28,15) + SAVE_INT(r29,16) + SAVE_INT(r30,17) + SAVE_INT(r31,18) - mr r3,r1 /* pass call stack pointer as an argument */ + SAVE_FP(f14,20) /* save FPRs */ + SAVE_FP(f15,22) + SAVE_FP(f16,24) + SAVE_FP(f17,26) + SAVE_FP(f18,28) + SAVE_FP(f19,30) + SAVE_FP(f20,32) + SAVE_FP(f21,34) + SAVE_FP(f22,36) + SAVE_FP(f23,38) + SAVE_FP(f24,40) + SAVE_FP(f25,42) + SAVE_FP(f26,44) + SAVE_FP(f27,46) + SAVE_FP(f28,48) + SAVE_FP(f29,50) + SAVE_FP(f30,52) + SAVE_FP(f31,54) + + SAVE_INT(r3,19) /* save quotation since we're about to mangle it */ + + mr r3,r1 /* pass call stack pointer as an argument */ bl MANGLE(save_callstack_bottom) - RESTORE(r3,19) /* restore quotation */ - CALL_QUOT + RESTORE_INT(r3,19) /* restore quotation */ + CALL_QUOT - RESTORE(r31,18) /* restore GPRs */ - RESTORE(r30,17) - RESTORE(r29,16) - RESTORE(r28,15) - RESTORE(r27,14) - RESTORE(r26,13) - RESTORE(r25,12) - RESTORE(r24,11) - RESTORE(r23,10) - RESTORE(r22,9) - RESTORE(r21,8) - RESTORE(r20,7) - RESTORE(r19,6) - RESTORE(r18,5) - RESTORE(r17,4) - RESTORE(r16,3) - /* don't restore rs pointer */ - /* don't restore ds pointer */ - RESTORE(r13,0) + RESTORE_FP(f31,54) + RESTORE_FP(f30,52) + RESTORE_FP(f29,50) + RESTORE_FP(f28,48) + RESTORE_FP(f27,46) + RESTORE_FP(f26,44) + RESTORE_FP(f25,42) + RESTORE_FP(f24,40) + RESTORE_FP(f23,38) + RESTORE_FP(f22,36) + RESTORE_FP(f21,34) + RESTORE_FP(f20,32) + RESTORE_FP(f19,30) + RESTORE_FP(f18,28) + RESTORE_FP(f17,26) + RESTORE_FP(f16,24) + RESTORE_FP(f15,22) + RESTORE_FP(f14,20) /* save FPRs */ - EPILOGUE - blr + RESTORE_INT(r31,18) /* restore GPRs */ + RESTORE_INT(r30,17) + RESTORE_INT(r29,16) + RESTORE_INT(r28,15) + RESTORE_INT(r27,14) + RESTORE_INT(r26,13) + RESTORE_INT(r25,12) + RESTORE_INT(r24,11) + RESTORE_INT(r23,10) + RESTORE_INT(r22,9) + RESTORE_INT(r21,8) + RESTORE_INT(r20,7) + RESTORE_INT(r19,6) + RESTORE_INT(r18,5) + RESTORE_INT(r17,4) + RESTORE_INT(r16,3) + /* don't restore rs pointer */ + /* don't restore ds pointer */ + RESTORE_INT(r13,0) + + EPILOGUE + blr /* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative trampoline to retrieve the function address */ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): - sub r1,r3,r5 /* compute new stack pointer */ - mr r3,r1 /* start of destination of memcpy() */ - stwu r1,-64(r1) /* setup fake stack frame for memcpy() */ - mtlr r6 /* prepare to call memcpy() */ - blrl /* go */ - lwz r1,0(r1) /* tear down fake stack frame */ - lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */ - mtlr r0 /* prepare to return to restored callstack */ - blr /* go */ + sub r1,r3,r5 /* compute new stack pointer */ + mr r3,r1 /* start of destination of memcpy() */ + stwu r1,-64(r1) /* setup fake stack frame for memcpy() */ + mtlr r6 /* prepare to call memcpy() */ + blrl /* go */ + lwz r1,0(r1) /* tear down fake stack frame */ + lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */ + mtlr r0 /* prepare to return to restored callstack */ + blr /* go */ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - mr r1,r4 /* compute new stack pointer */ + mr r1,r4 /* compute new stack pointer */ lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */ mtlr r0 - JUMP_QUOT /* call the quotation */ + JUMP_QUOT /* call the quotation */ DEF(void,lazy_jit_compile,(CELL quot)): - mr r4,r1 /* save stack pointer */ + mr r4,r1 /* save stack pointer */ PROLOGUE bl MANGLE(primitive_jit_compile) EPILOGUE - JUMP_QUOT /* call the quotation */ + JUMP_QUOT /* call the quotation */ /* Thanks to Joshua Grams for this code. @@ -136,19 +181,19 @@ On PowerPC processors, we must flush the instruction cache manually after writing to the code heap. */ DEF(void,flush_icache,(void *start, int len)): - /* compute number of cache lines to flush */ - add r4,r4,r3 - clrrwi r3,r3,5 /* align addr to next lower cache line boundary */ - sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */ - addi r4,r4,0x1f - srwi. r4,r4,5 /* note '.' suffix */ - beqlr /* if n_lines == 0, just return. */ - mtctr r4 /* flush cache lines */ -0: dcbf 0,r3 /* for each line... */ - sync - icbi 0,r3 - addi r3,r3,0x20 - bdnz 0b - sync /* finish up */ - isync - blr + /* compute number of cache lines to flush */ + add r4,r4,r3 + clrrwi r3,r3,5 /* align addr to next lower cache line boundary */ + sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */ + addi r4,r4,0x1f + srwi. r4,r4,5 /* note '.' suffix */ + beqlr /* if n_lines == 0, just return. */ + mtctr r4 /* flush cache lines */ +0: dcbf 0,r3 /* for each line... */ + sync + icbi 0,r3 + addi r3,r3,0x20 + bdnz 0b + sync /* finish up */ + isync + blr diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index 810aef8b5d..0f10aa34aa 100755 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -1,8 +1,8 @@ #define FACTOR_CPU_STRING "ppc" #define F_FASTCALL -register CELL ds asm("r14"); -register CELL rs asm("r15"); +register CELL ds asm("r30"); +register CELL rs asm("r31"); void c_to_factor(CELL quot); void undefined(CELL word); From affb48a067cd60026eb7d07402d8297347e76fdb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:27:12 -0600 Subject: [PATCH 08/12] Fix docs --- basis/unix/groups/groups-docs.factor | 23 ++++++------------- basis/unix/users/users-docs.factor | 33 +++++++++------------------- 2 files changed, 17 insertions(+), 39 deletions(-) diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor index ef2631ae3f..18c2e2384a 100644 --- a/basis/unix/groups/groups-docs.factor +++ b/basis/unix/groups/groups-docs.factor @@ -4,21 +4,15 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str IN: unix.groups HELP: all-groups -{ $values - - { "seq" sequence } } +{ $values { "seq" sequence } } { $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ; HELP: effective-group-id -{ $values - - { "string" string } } +{ $values { "string" string } } { $description "Returns the effective group id for the current user." } ; HELP: effective-group-name -{ $values - - { "string" string } } +{ $values { "string" string } } { $description "Returns the effective group name for the current user." } ; HELP: group @@ -46,15 +40,11 @@ HELP: group-struct { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ; HELP: real-group-id -{ $values - - { "id" integer } } +{ $values { "id" integer } } { $description "Returns the real group id for the current user." } ; HELP: real-group-name -{ $values - - { "string" string } } +{ $values { "string" string } } { $description "Returns the real group name for the current user." } ; HELP: set-effective-group @@ -88,8 +78,9 @@ HELP: with-real-group { "string/id" "a string or a group id" } { "quot" quotation } } { $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ; -ARTICLE: "unix.groups" "unix.groups" +ARTICLE: "unix.groups" "Unix groups" "The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups." +$nl "Listing all groups:" { $subsection all-groups } "Returning a passwd tuple:" diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index f8586ffc35..c466ad1575 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -4,27 +4,19 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str IN: unix.users HELP: all-users -{ $values - - { "seq" sequence } } +{ $values { "seq" sequence } } { $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ; HELP: effective-username -{ $values - - { "string" string } } +{ $values { "string" string } } { $description "Returns the effective username for the current user." } ; HELP: effective-user-id -{ $values - - { "id" integer } } +{ $values { "id" integer } } { $description "Returns the effective username id for the current user." } ; HELP: new-passwd -{ $values - - { "passwd" passwd } } +{ $values { "passwd" passwd } } { $description "Creates a new passwd tuple dependent on the operating system." } ; HELP: passwd @@ -40,25 +32,19 @@ HELP: passwd>new-passwd { $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ; HELP: real-username -{ $values - - { "string" string } } +{ $values { "string" string } } { $description "The real username of the current user." } ; HELP: real-user-id -{ $values - - { "id" integer } } +{ $values { "id" integer } } { $description "The real user id of the current user." } ; HELP: set-effective-user -{ $values - { "string/id" "a string or a user id" } } +{ $values { "string/id" "a string or a user id" } } { $description "Sets the current effective user given a username or a user id." } ; HELP: set-real-user -{ $values - { "string/id" "a string or a user id" } } +{ $values { "string/id" "a string or a user id" } } { $description "Sets the current real user given a username or a user id." } ; HELP: user-passwd @@ -100,8 +86,9 @@ HELP: with-real-user set-effective-user } related-words -ARTICLE: "unix.users" "unix.users" +ARTICLE: "unix.users" "Unix users" "The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users." +$nl "Listing all users:" { $subsection all-users } "Returning a passwd tuple:" From 7f59942219260c109efe0ffa63c0d9115e2bb4bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 04:28:13 -0600 Subject: [PATCH 09/12] Change title to be more consistent --- basis/ui/tools/tools-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 7f7b012a35..f54e1e4041 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -117,7 +117,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts" { $heading "Implementation" } "Workspaces are instances of " { $link workspace } "." ; -ARTICLE: "ui-tools" "UI development tools" +ARTICLE: "ui-tools" "UI developer tools" "The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.." $nl "To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "." From 81c7320f7b89dda21843fb9d88d2878d5bd723c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 05:14:35 -0600 Subject: [PATCH 10/12] mason.updates was calling download-my-image, which uses the current CPU/OS instead of target-cpu and target-os. So doing 32-bit builds from a 64-bit Factor instance didn't work... oops --- extra/mason/platform/platform.factor | 12 +++++------- extra/mason/updates/updates.factor | 3 ++- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index e4bba51491..cd7d3f3836 100644 --- a/extra/mason/platform/platform.factor +++ b/extra/mason/platform/platform.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel system accessors namespaces splitting sequences make +USING: kernel system accessors namespaces splitting sequences mason.config ; IN: mason.platform @@ -10,10 +10,8 @@ IN: mason.platform : gnu-make ( -- string ) target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ; +: boot-image-arch ( -- string ) + target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ; + : boot-image-name ( -- string ) - [ - "boot." % - target-cpu get "ppc" = [ target-os get % "-" % ] when - target-cpu get % - ".image" % - ] "" make ; + "boot." boot-image-arch ".image" 3append ; diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor index 9c42ba2850..b3f6847c35 100644 --- a/extra/mason/updates/updates.factor +++ b/extra/mason/updates/updates.factor @@ -20,7 +20,8 @@ IN: mason.updates = not ; : new-image-available? ( -- ? ) - boot-image-name need-new-image? [ download-my-image t ] [ f ] if ; + boot-image-name need-new-image? + [ boot-image-arch download-image t ] [ f ] if ; : new-code-available? ( -- ? ) updates-available? From 4fd1767768c85332913d208c32a6abb8f2a0ce28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 18:32:02 -0600 Subject: [PATCH 11/12] Old fix for classes-intersect? no-method bug was incorrect; we were ignoring anonymous classes in compiled-generic-crossref. Also, forget* now calls reset-word so that references to predicates of forgotten classes don't break the compiler with a similar error. --- basis/compiler/tests/redefine12.factor | 20 +++++++++++++++ core/classes/algebra/algebra.factor | 8 ++++++ core/classes/classes-tests.factor | 34 ++++++++++++++++++++++++++ core/classes/classes.factor | 24 +++++++++--------- core/compiler/units/units.factor | 2 +- core/words/words.factor | 12 +++------ 6 files changed, 80 insertions(+), 20 deletions(-) create mode 100644 basis/compiler/tests/redefine12.factor diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor new file mode 100644 index 0000000000..87dc4596e9 --- /dev/null +++ b/basis/compiler/tests/redefine12.factor @@ -0,0 +1,20 @@ +USING: kernel tools.test eval ; +IN: compiler.tests.redefine12 + +! A regression that came about when fixing the +! 'no method on classes-intersect?' bug + +GENERIC: g ( a -- b ) + +M: object g drop t ; + +: h ( a -- b ) dup [ g ] when ; + +[ f ] [ f h ] unit-test +[ t ] [ "hi" h ] unit-test + +TUPLE: jeah ; + +[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test + +[ f ] [ T{ jeah } h ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 51dad033a9..b7e6800950 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -20,6 +20,14 @@ C: anonymous-complement : 2cache ( key1 key2 assoc quot -- value ) >r >r 2array r> [ first2 ] r> compose cache ; inline +GENERIC: valid-class? ( obj -- ? ) + +M: class valid-class? drop t ; +M: anonymous-union valid-class? members>> [ valid-class? ] all? ; +M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ; +M: anonymous-complement valid-class? class>> valid-class? ; +M: word valid-class? drop f ; + DEFER: (class<=) : class<= ( first second -- ? ) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c7900da316..673c108b27 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -79,3 +79,37 @@ USE: multiline : q ( -- b ) j new g ;"> "class-intersect-no-method-b" parse-stream drop ] unit-test + +! Similar problem, but with anonymous classes +[ ] [ + <" IN: classes.test.c + USE: kernel + GENERIC: g ( a -- b ) + M: object g ; + TUPLE: z ;"> + "class-intersect-no-method-c" parse-stream drop +] unit-test + +[ ] [ + <" IN: classes.test.d + USE: classes.test.c + USE: kernel + : q ( a -- b ) dup z? [ g ] unless ;"> + "class-intersect-no-method-d" parse-stream drop +] unit-test + +! Now, the user removes the z class and adds a method, +[ ] [ + <" IN: classes.test.c + USE: kernel + GENERIC: g ( a -- b ) + M: object g ; + TUPLE: j ; + M: j g ;"> + "class-intersect-no-method-c" parse-stream drop +] unit-test + +TUPLE: forgotten-predicate-test ; + +[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test +[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 70fb869c5c..2ce4b934c8 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -32,8 +32,7 @@ SYMBOL: update-map SYMBOL: implementors-map -PREDICATE: class < word - "class" word-prop ; +PREDICATE: class < word "class" word-prop ; : classes ( -- seq ) implementors-map get keys ; @@ -42,9 +41,12 @@ PREDICATE: class < word PREDICATE: predicate < word "predicating" word-prop >boolean ; +M: predicate reset-word + [ call-next-method ] [ { "predicating" } reset-props ] bi ; + : define-predicate ( class quot -- ) - >r "predicate" word-prop first - r> (( object -- ? )) define-declared ; + [ "predicate" word-prop first ] dip + (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ; ] H{ } make-assoc ; : (define-class) ( word props -- ) - >r - dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless - dup reset-class - dup deferred? [ dup define-symbol ] when - dup redefined - dup props>> - r> assoc-union >>props + [ + dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless + dup reset-class + dup deferred? [ dup define-symbol ] when + dup redefined + dup props>> + ] dip assoc-union >>props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 1b6b934dae..72496a5f76 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook : (compiled-generic-usages) ( generic class -- assoc ) [ compiled-generic-usage ] dip [ - 2dup [ class? ] both? + 2dup [ valid-class? ] both? [ classes-intersect? ] [ 2drop f ] if nip ] curry assoc-filter ; diff --git a/core/words/words.factor b/core/words/words.factor index b7b34f1d22..ce1fdf194b 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- ) M: word reset-word { - "unannotated-def" - "parsing" "inline" "recursive" "foldable" "flushable" - "predicating" - "reading" "writing" - "reader" "writer" - "constructing" - "declared-effect" "constructor-quot" "delimiter" + "unannotated-def" "parsing" "inline" "recursive" + "foldable" "flushable" "reading" "writing" "reader" + "writer" "declared-effect" "delimiter" } reset-props ; GENERIC: subwords ( word -- seq ) @@ -261,7 +257,7 @@ M: word forget* dup "forgotten" word-prop [ drop ] [ [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] - [ t "forgotten" set-word-prop ] + [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ] tri ] if ; From fbb958da829d40b43c1d0ff3b0ed616f07b43703 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 18:59:58 -0600 Subject: [PATCH 12/12] Fix lambda-method forget --- basis/locals/locals-tests.factor | 9 ++++++++- basis/locals/locals.factor | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index c449c26348..003ef459e3 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -1,7 +1,8 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit -combinators.short-circuit.smart math.order math.functions ; +combinators.short-circuit.smart math.order math.functions +definitions compiler.units ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -378,6 +379,12 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ 9 ] [ 3 big-case-test ] unit-test +GENERIC: lambda-method-forget-test ( a -- b ) + +M:: integer lambda-method-forget-test ( a -- b ) ; + +[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test + ! :: wlet-&&-test ( a -- ? ) ! [wlet | is-integer? [ a integer? ] ! is-even? [ a even? ] diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 89a5c02746..c588269284 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -450,7 +450,7 @@ M: lambda-method definition "lambda" word-prop body>> ; M: lambda-method reset-word - [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; INTERSECTION: lambda-memoized memoized lambda-word ;