From: Slava Pestov Date: Tue, 29 Jul 2008 21:47:52 +0000 (-0500) Subject: Add 'unportable' tag in place of hard-coded list of 'dangerous' vocabs in load-everything X-Git-Tag: 0.94~2708 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=6408b01e9dec05aada22c65b259e5a03354e45b5 Add 'unportable' tag in place of hard-coded list of 'dangerous' vocabs in load-everything --- diff --git a/basis/calendar/unix/tags.txt b/basis/calendar/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/calendar/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/calendar/windows/tags.txt b/basis/calendar/windows/tags.txt index 8e1a55995e..02ec70f741 100644 --- a/basis/calendar/windows/tags.txt +++ b/basis/calendar/windows/tags.txt @@ -1 +1,2 @@ +unportable windows diff --git a/basis/cocoa/application/tags.txt b/basis/cocoa/application/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/application/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/callbacks/tags.txt b/basis/cocoa/callbacks/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/callbacks/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/dialogs/tags.txt b/basis/cocoa/dialogs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/dialogs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/enumeration/tags.txt b/basis/cocoa/enumeration/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/enumeration/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/messages/tags.txt b/basis/cocoa/messages/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/messages/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/nibs/tags.txt b/basis/cocoa/nibs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/nibs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/pasteboard/tags.txt b/basis/cocoa/pasteboard/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/pasteboard/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/plists/tags.txt b/basis/cocoa/plists/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/plists/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/runtime/tags.txt b/basis/cocoa/runtime/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/runtime/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/subclassing/tags.txt b/basis/cocoa/subclassing/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/subclassing/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/tags.txt b/basis/cocoa/tags.txt index bb863cf9a0..2320bdd648 100644 --- a/basis/cocoa/tags.txt +++ b/basis/cocoa/tags.txt @@ -1 +1,2 @@ +unportable bindings diff --git a/basis/cocoa/types/tags.txt b/basis/cocoa/types/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/types/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/views/tags.txt b/basis/cocoa/views/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/views/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/windows/tags.txt b/basis/cocoa/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/core-foundation/fsevents/tags.txt b/basis/core-foundation/fsevents/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/core-foundation/fsevents/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/core-foundation/run-loop/tags.txt b/basis/core-foundation/run-loop/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/core-foundation/run-loop/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/core-foundation/tags.txt b/basis/core-foundation/tags.txt index bb863cf9a0..2320bdd648 100644 --- a/basis/core-foundation/tags.txt +++ b/basis/core-foundation/tags.txt @@ -1 +1,2 @@ +unportable bindings diff --git a/basis/cpu/arm/4/4.factor b/basis/cpu/arm/4/4.factor deleted file mode 100755 index 0d317fd553..0000000000 --- a/basis/cpu/arm/4/4.factor +++ /dev/null @@ -1,45 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.architecture cpu.arm.assembler -cpu.arm.architecture cpu.arm5.assembler kernel kernel.private -math math.private namespaces sequences words quotations -byte-arrays hashtables.private hashtables generator -generator.registers generator.fixup sequences.private -strings.private ; -IN: cpu.arm4 - -: (%char-slot) - "out" operand string-offset MOV - "out" operand dup "n" operand 2 ADD ; - -\ char-slot [ - (%char-slot) - "out" operand "obj" operand "out" operand <+> LDRH - "out" operand dup %tag-fixnum -] H{ - { +input+ { { f "n" } { f "obj" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ set-char-slot [ - "val" operand dup %untag-fixnum - (%char-slot) - "val" operand "obj" operand "out" operand <+> STRH -] H{ - { +input+ { { f "val" } { f "n" } { f "obj" } } } - { +scratch+ { { f "out" } } } - { +clobber+ { "val" } } -} define-intrinsic - -\ alien-signed-1 [ LDRSB ] -\ set-alien-signed-1 [ STRB ] -define-alien-integer-intrinsics - -\ alien-unsigned-2 [ LDRH ] -\ set-alien-unsigned-2 [ STRH ] -define-alien-integer-intrinsics - -\ alien-signed-2 [ LDRSH ] -\ set-alien-signed-2 [ STRH ] -define-alien-integer-intrinsics diff --git a/basis/cpu/arm/4/authors.txt b/basis/cpu/arm/4/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/cpu/arm/4/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/4/summary.txt b/basis/cpu/arm/4/summary.txt deleted file mode 100644 index 7be5231690..0000000000 --- a/basis/cpu/arm/4/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Additional compiler intrinsics for ARM4 diff --git a/basis/cpu/arm/allot/allot.factor b/basis/cpu/arm/allot/allot.factor deleted file mode 100755 index 27a4676926..0000000000 --- a/basis/cpu/arm/allot/allot.factor +++ /dev/null @@ -1,79 +0,0 @@ -! Copyright (C) 2006, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel cpu.architecture cpu.arm.assembler -cpu.arm.architecture namespaces math sequences -generator generator.registers generator.fixup system layouts -alien ; -IN: cpu.arm.allot - -: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ; - -: %allot ( header size -- ) - #! Store a pointer to 'size' bytes allocated from the - #! nursery in R11 - 8 align ! align the size - R12 load-zone-ptr ! nusery -> r12 - R11 R12 cell <+> LDR ! nursery.here -> r11 - R11 R11 pick ADD ! increment r11 - R11 R12 cell <+> STR ! r11 -> nursery.here - R11 R11 rot SUB ! old value - R12 swap type-number tag-fixnum MOV ! compute header - R12 R11 0 <+> STR ! store header - ; - -: %store-tagged ( reg tag -- ) - >r dup fresh-object v>operand R11 r> tag-number ORR ; - -: %allot-bignum ( #digits -- ) - #! 1 cell header, 1 cell length, 1 cell sign, + digits - #! length is the # of digits + sign - bignum over 3 + cells %allot - R12 swap 1+ v>operand MOV ! compute the length - R12 R11 cell <+> STR ! store the length - ; - -: %allot-bignum-signed-1 ( dst src -- ) - #! on entry, reg is a 30-bit quantity sign-extended to - #! 32-bits. - #! exits with tagged ptr to bignum in reg. - [ - "end" define-label - ! is it zero? - dup v>operand 0 CMP - 0 >bignum pick EQ load-literal - "end" get EQ B - ! ! it is non-zero - 1 %allot-bignum - ! is the fixnum negative? - dup v>operand 0 CMP - ! negative sign - R12 1 LT MOV - ! negate fixnum - dup v>operand dup 0 LT RSB - ! positive sign - R12 0 GE MOV - ! store sign - R12 R11 2 cells <+> STR - ! store the number - v>operand R11 3 cells <+> STR - ! tag the bignum, store it in reg - bignum %store-tagged - "end" resolve-label - ] with-scope ; - -M: arm-backend %box-alien ( dst src -- ) - "end" define-label - dup v>operand 0 CMP - over v>operand f v>operand EQ MOV - "end" get EQ B - alien 4 cells %allot - ! Store offset - v>operand R11 3 cells <+> STR - R12 f v>operand MOV - ! Store expired slot - R12 R11 1 cells <+> STR - ! Store underlying-alien slot - R12 R11 2 cells <+> STR - ! Store tagged ptr in reg - object %store-tagged - "end" resolve-label ; diff --git a/basis/cpu/arm/allot/authors.txt b/basis/cpu/arm/allot/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/arm/allot/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/architecture/architecture.factor b/basis/cpu/arm/architecture/architecture.factor deleted file mode 100755 index 563dd10bc4..0000000000 --- a/basis/cpu/arm/architecture/architecture.factor +++ /dev/null @@ -1,370 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays cpu.arm.assembler compiler -kernel kernel.private math namespaces words words.private -generator.registers generator.fixup generator cpu.architecture -system layouts ; -IN: cpu.arm.architecture - -TUPLE: arm-backend ; - -! ARM register assignments: -! R0-R4, R7-R10 integer vregs -! R11, R12 temporary -! R5 data stack -! R6 retain stack -! R7 primitives - -: ds-reg R5 ; inline -: rs-reg R6 ; inline - -M: temp-reg v>operand drop R12 ; - -M: int-regs return-reg drop R0 ; -M: int-regs param-regs drop { R0 R1 R2 R3 } ; -M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ; - -! No FPU support yet -M: float-regs param-regs drop { } ; -M: float-regs vregs drop { } ; - -: <+/-> dup 0 < [ neg <-> ] [ <+> ] if ; - -GENERIC: loc>operand ( loc -- reg addressing ) -M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap <+/-> ; -M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ; - -: load-cell ( reg -- ) - [ - "end" define-label - ! Load target address - PC 0 <+> LDR - ! Skip an instruction - "end" get B - ! The target address - 0 , - ! Continue here - "end" resolve-label - ] with-scope ; - -: call-cell ( -- ) - ! Compute return address; we skip 3 instructions - LR PC 8 ADD - ! Load target address - R12 PC 0 <+> LDR - ! Jump to target address - R12 BX - ! The target address - 0 , ; - -M: arm-backend load-indirect ( obj reg -- ) - tuck load-cell rc-absolute-cell rel-literal - dup 0 <+> LDR ; - -M: immediate load-literal - over v>operand small-enough? [ - [ v>operand ] bi@ swap MOV - ] [ - v>operand load-indirect - ] if ; - -: lr-save ( n -- i ) cell - ; -: next-save ( n -- i ) 2 cells - ; -: xt-save ( n -- i ) 3 cells - ; -: factor-area-size 5 cells ; - -M: arm-backend stack-frame ( n -- i ) - factor-area-size + 8 align ; - -M: arm-backend %save-word-xt ( -- ) - R12 PC 9 cells SUB ; - -M: arm-backend %save-dispatch-xt ( -- ) - R12 PC 2 cells SUB ; - -M: arm-backend %prologue ( n -- ) - SP SP pick SUB - R11 over MOV - R11 SP pick next-save <+> STR - R12 SP pick xt-save <+> STR - LR SP rot lr-save <+> STR ; - -M: arm-backend %epilogue ( n -- ) - LR SP pick lr-save <+> LDR - SP SP rot ADD ; - -: compile-dlsym ( symbol dll reg -- ) - load-cell rc-absolute rel-dlsym ; - -: %alien-global ( symbol dll reg -- ) - [ compile-dlsym ] keep dup 0 <+> LDR ; - -M: arm-backend %profiler-prologue ( -- ) - #! We can clobber R0 here since it is undefined at the start - #! of a word. - R12 load-indirect - R0 R12 profile-count-offset <+> LDR - R0 R0 1 v>operand ADD - R0 R12 profile-count-offset <+> STR ; - -M: arm-backend %call-label ( label -- ) BL ; - -M: arm-backend %jump-label ( label -- ) B ; - -: %prepare-primitive ( -- ) - #! Save stack pointer to stack_chain->callstack_top, load XT - R1 SP 4 SUB ; - -M: arm-backend %call-primitive ( word -- ) - %prepare-primitive - call-cell rc-absolute-cell rel-word ; - -M: arm-backend %jump-primitive ( word -- ) - %prepare-primitive - ! Load target address - R12 PC 0 <+> LDR - ! Jump to target address - R12 BX - ! The target address - 0 , rc-absolute-cell rel-word ; - -M: arm-backend %jump-t ( label -- ) - "flag" operand f v>operand CMP NE B ; - -: (%dispatch) ( word-table# -- ) - #! Load jump table target address into reg. - "scratch" operand PC "n" operand 1 ADD - "scratch" operand dup 0 <+> LDR - rc-indirect-arm rel-dispatch - "scratch" operand dup compiled-header-size ADD ; - -M: arm-backend %call-dispatch ( word-table# -- ) - [ - (%dispatch) - "scratch" operand BLX - ] H{ - { +input+ { { f "n" } } } - { +scratch+ { { f "scratch" } } } - } with-template ; - -M: arm-backend %jump-dispatch ( word-table# -- ) - [ - %epilogue-later - (%dispatch) - "scratch" operand BX - ] H{ - { +input+ { { f "n" } } } - { +scratch+ { { f "scratch" } } } - } with-template ; - -M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ; - -M: arm-backend %unwind drop %return ; - -M: arm-backend %peek >r v>operand r> loc>operand LDR ; - -M: arm-backend %replace >r v>operand r> loc>operand STR ; - -: (%inc) ( n reg -- ) - dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ; - -M: arm-backend %inc-d ( n -- ) ds-reg (%inc) ; - -M: arm-backend %inc-r ( n -- ) rs-reg (%inc) ; - -: stack@ SP swap <+> ; - -M: int-regs %save-param-reg drop swap stack@ STR ; - -M: int-regs %load-param-reg drop swap stack@ LDR ; - -M: stack-params %save-param-reg - drop - R12 swap stack-frame* + stack@ LDR - R12 swap stack@ STR ; - -M: stack-params %load-param-reg - drop - R12 rot stack@ LDR - R12 swap stack@ STR ; - -M: arm-backend %prepare-unbox ( -- ) - ! First parameter is top of stack - R0 R5 4 <-!> LDR ; - -M: arm-backend %unbox ( n reg-class func -- ) - ! Value must be in R0. - ! Call the unboxer - f %alien-invoke - ! Store the return value on the C stack - over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; - -M: arm-backend %unbox-long-long ( n func -- ) - ! Value must be in R0:R1. - ! Call the unboxer - f %alien-invoke - ! Store the return value on the C stack - [ - R0 over stack@ STR - R1 swap cell + stack@ STR - ] when* ; - -M: arm-backend %unbox-small-struct ( size -- ) - #! Alien must be in R0. - drop - "alien_offset" f %alien-invoke - ! Load first cell - R0 R0 0 <+> LDR ; - -M: arm-backend %unbox-large-struct ( n size -- ) - #! Alien must be in R0. - ! Compute destination address - R1 SP roll ADD - R2 swap MOV - ! Copy the struct to the stack - "to_value_struct" f %alien-invoke ; - -M: arm-backend %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: arm-backend %box-long-long ( n func -- ) - >r [ - R0 over stack@ LDR - R1 swap cell + stack@ LDR - ] when* r> f %alien-invoke ; - -M: arm-backend %box-small-struct ( size -- ) - #! Box a 4-byte struct returned in R0. - R2 swap MOV - "box_small_struct" f %alien-invoke ; - -: temp@ stack-frame* factor-area-size - swap - ; - -: struct-return@ ( size n -- n ) - [ - stack-frame* + - ] [ - stack-frame* factor-area-size - swap - - ] ?if ; - -M: arm-backend %prepare-box-struct ( size -- ) - ! Compute target address for value struct return - R0 SP rot f struct-return@ ADD - ! Store it as the first parameter - R0 0 stack@ STR ; - -M: arm-backend %box-large-struct ( n size -- ) - ! Compute destination address - [ swap struct-return@ ] keep - R0 SP roll ADD - R1 swap MOV - ! Copy the struct from the C stack - "box_value_struct" f %alien-invoke ; - -M: arm-backend struct-small-enough? ( size -- ? ) - wince? [ drop f ] [ 4 <= ] if ; - -M: arm-backend %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 R12 %alien-global - SP R12 0 <+> STR - ds-reg R12 8 <+> STR - rs-reg R12 12 <+> STR ; - -M: arm-backend %alien-invoke ( symbol dll -- ) - call-cell rc-absolute-cell rel-dlsym ; - -M: arm-backend %prepare-alien-indirect ( -- ) - "unbox_alien" f %alien-invoke - R0 SP cell temp@ <+> STR ; - -M: arm-backend %alien-indirect ( -- ) - R12 SP cell temp@ <+> LDR - R12 BLX ; - -M: arm-backend %alien-callback ( quot -- ) - R0 load-indirect - "c_to_factor" f %alien-invoke ; - -M: arm-backend %callback-value ( ctype -- ) - ! Save top of data stack - %prepare-unbox - R0 SP cell temp@ <+> STR - ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke - ! Place former top of data stack in R0 - R0 SP cell temp@ <+> LDR - ! Unbox R0 - unbox-return ; - -M: arm-backend %cleanup ( alien-node -- ) drop ; - -: %untag ( dest src -- ) BIN: 111 BIC ; - -: %untag-fixnum ( dest src -- ) tag-bits get MOV ; - -: %tag-fixnum ( dest src -- ) tag-bits get MOV ; - -M: arm-backend value-structs? t ; - -M: arm-backend small-enough? ( n -- ? ) 0 255 between? ; - -M: long-long-type c-type-stack-align? drop wince? not ; - -M: arm-backend fp-shadows-int? ( -- ? ) f ; - -! Alien intrinsics -M: arm-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] bi@ byte-array-offset ADD ; - -M: arm-backend %unbox-alien ( dst src -- ) - [ v>operand ] bi@ alien-offset <+> LDR ; - -M: arm-backend %unbox-f ( dst src -- ) - drop v>operand 0 MOV ; - -M: arm-backend %unbox-any-c-ptr ( dst src -- ) - #! We need three registers here. R11 and R12 are reserved - #! temporary registers. The third one is R14, which we have - #! to save/restore. - "end" define-label - "start" define-label - ! Save R14. - R14 SP 4 <-> STR - ! Address is computed in R11 - R11 0 MOV - ! Load object into R12 - R12 swap v>operand MOV - ! We come back here with displaced aliens - "start" resolve-label - ! Is the object f? - R12 f v>operand CMP - ! If so, done - "end" get EQ B - ! Is the object an alien? - R14 R12 header-offset <+/-> LDR - R14 alien type-number tag-fixnum CMP - ! Add byte array address to address being computed - R11 R11 R12 NE ADD - ! Add an offset to start of byte array's data area - R11 R11 byte-array-offset NE ADD - "end" get NE B - ! If alien, load the offset - R14 R12 alien-offset <+/-> LDR - ! Add it to address being computed - R11 R11 R14 ADD - ! Now recurse on the underlying alien - R12 R12 underlying-alien-offset <+/-> LDR - "start" get B - "end" resolve-label - ! Done, store address in destination register - v>operand R11 MOV - ! Restore R14. - R14 SP 4 <-> LDR ; diff --git a/basis/cpu/arm/architecture/authors.txt b/basis/cpu/arm/architecture/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/arm/architecture/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/arm.factor b/basis/cpu/arm/arm.factor deleted file mode 100755 index 2bad556f83..0000000000 --- a/basis/cpu/arm/arm.factor +++ /dev/null @@ -1,56 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math namespaces -cpu.architecture cpu.arm.architecture cpu.arm.assembler -cpu.arm.intrinsics generator generator.registers continuations -compiler io vocabs.loader sequences system ; - -! EABI passes floats in integer registers. -[ alien-float ] -[ >r >r >float r> r> set-alien-float ] -4 -"box_float" -"to_float" -"float" define-primitive-type - -[ >float ] "float" c-type set-c-type-prep - -[ alien-double ] -[ >r >r >float r> r> set-alien-double ] -8 -"box_double" -"to_double" -"double" define-primitive-type - -[ >float ] "double" c-type set-c-type-prep - -T{ arm-backend } compiler-backend set-global - -! We don't auto-detect since that would require us to support -! illegal instruction traps. This works on Linux but not on -! Windows CE. - -"arm-variant" get [ - "ARM variant: " write "arm-variant" get print -] [ - "==========" print - "You should specify the -arm-variant= switch." print - " can be one of arm3, arm4, arm4t, or arm5." print - "Assuming arm3." print - "==========" print - "arm3" "arm-variant" set-global -] if - -"arm-variant" get { "arm4" "arm4t" "arm5" } member? [ - "cpu.arm.4" require -] when - -"arm-variant" get { "arm4t" "arm5" } member? [ - t have-BX? set-global -] when - -"arm-variant" get "arm5" = [ - t have-BLX? set-global -] when - -7 cells profiler-prologues set-global diff --git a/basis/cpu/arm/assembler/assembler-tests.factor b/basis/cpu/arm/assembler/assembler-tests.factor deleted file mode 100644 index a30ab9f797..0000000000 --- a/basis/cpu/arm/assembler/assembler-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -IN: cpu.arm.assembler.tests -USING: assembler-arm math test namespaces sequences kernel -quotations ; - -: test-opcode [ { } make first ] curry unit-test ; - -[ HEX: ea000000 ] [ 0 B ] test-opcode -[ HEX: eb000000 ] [ 0 BL ] test-opcode -! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode - -[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode -[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode -[ HEX: e087e3ac ] [ LR R7 IP 7 ADD ] test-opcode -[ HEX: e08c0109 ] [ R0 IP R9 2 ADD ] test-opcode -[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode -[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode - -[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode -[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode -[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode -[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode -[ HEX: e1e01c80 ] [ R1 R0 25 MVN ] test-opcode -[ HEX: e1e00ca1 ] [ R0 R1 25 MVN ] test-opcode -[ HEX: 11a021ac ] [ R2 IP 3 NE MOV ] test-opcode - -[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode - -[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode - -[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode -[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode -[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode - -[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode -[ HEX: e7910102 ] [ R0 R1 R2 2 <+> LDR ] test-opcode - -[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode -[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode -[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode -[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode -[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode -[ HEX: e1f310fc ] [ R1 R3 12 LDRSH ] test-opcode -[ HEX: e1b310d4 ] [ R1 R3 R4 LDRSB ] test-opcode -[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode -[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode diff --git a/basis/cpu/arm/assembler/assembler.factor b/basis/cpu/arm/assembler/assembler.factor deleted file mode 100755 index 5a69f93d85..0000000000 --- a/basis/cpu/arm/assembler/assembler.factor +++ /dev/null @@ -1,330 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generator generator.fixup kernel sequences words -namespaces math math.bitfields ; -IN: cpu.arm.assembler - -: define-registers ( seq -- ) - dup length [ "register" set-word-prop ] 2each ; - -SYMBOL: R0 -SYMBOL: R1 -SYMBOL: R2 -SYMBOL: R3 -SYMBOL: R4 -SYMBOL: R5 -SYMBOL: R6 -SYMBOL: R7 -SYMBOL: R8 -SYMBOL: R9 -SYMBOL: R10 -SYMBOL: R11 -SYMBOL: R12 -SYMBOL: R13 -SYMBOL: R14 -SYMBOL: R15 - -{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 } -define-registers - -PREDICATE: register < word register >boolean ; - -GENERIC: register ( register -- n ) -M: word register "register" word-prop ; -M: f register drop 0 ; - -: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline -: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline - -! Condition codes -SYMBOL: cond-code - -: >CC ( n -- ) - cond-code set ; - -: CC> ( -- n ) - #! Default value is BIN: 1110 AL (= always) - cond-code [ f ] change BIN: 1110 or ; - -: EQ BIN: 0000 >CC ; -: NE BIN: 0001 >CC ; -: CS BIN: 0010 >CC ; -: CC BIN: 0011 >CC ; -: LO BIN: 0100 >CC ; -: PL BIN: 0101 >CC ; -: VS BIN: 0110 >CC ; -: VC BIN: 0111 >CC ; -: HI BIN: 1000 >CC ; -: LS BIN: 1001 >CC ; -: GE BIN: 1010 >CC ; -: LT BIN: 1011 >CC ; -: GT BIN: 1100 >CC ; -: LE BIN: 1101 >CC ; -: AL BIN: 1110 >CC ; -: NV BIN: 1111 >CC ; - -: (insn) ( n -- ) CC> 28 shift bitor , ; - -: insn ( bitspec -- ) bitfield (insn) ; inline - -! Branching instructions -GENERIC# (B) 1 ( signed-imm-24 l -- ) - -M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ; -M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ; -M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ; - -: B 0 (B) ; : BL 1 (B) ; - -! Data processing instructions -SYMBOL: updates-cond-code - -: S ( -- ) updates-cond-code on ; - -: S> ( -- ? ) updates-cond-code [ f ] change ; - -: sinsn ( bitspec -- ) - bitfield S> [ 20 2^ bitor ] when (insn) ; inline - -GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n ) - -M: integer shift-imm/reg ( shift-imm Rm shift -- n ) - { { 0 4 } 5 { register 0 } 7 } bitfield ; - -M: register shift-imm/reg ( Rs Rm shift -- n ) - { - { 1 4 } - { 0 7 } - 5 - { register 8 } - { register 0 } - } bitfield ; - -GENERIC: shifter-op ( shifter-op -- n ) - -TUPLE: IMM immed rotate ; -C: IMM - -M: IMM shifter-op - dup IMM-immed swap IMM-rotate - { { 1 25 } 8 0 } bitfield ; - -TUPLE: shifter Rm by shift ; -C: shifter - -M: shifter shifter-op - dup shifter-by over shifter-Rm rot shifter-shift - shift-imm/reg ; - -: ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 ; -: ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 ; -: ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 ; -: ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 ; -: ( Rm -- shifter-op ) 0 ; - -M: register shifter-op 0 shifter-op ; - -M: integer shifter-op 0 shifter-op ; - -: addr1 ( Rd Rn shifter-op opcode -- ) - { - 21 ! opcode - { shifter-op 0 } - { register 16 } ! Rn - { register 12 } ! Rd - } sinsn ; - -: AND BIN: 0000 addr1 ; -: EOR BIN: 0001 addr1 ; -: SUB BIN: 0010 addr1 ; -: RSB BIN: 0011 addr1 ; -: ADD BIN: 0100 addr1 ; -: ADC BIN: 0101 addr1 ; -: SBC BIN: 0110 addr1 ; -: RSC BIN: 0111 addr1 ; -: ORR BIN: 1100 addr1 ; -: BIC BIN: 1110 addr1 ; - -: MOV f swap BIN: 1101 addr1 ; -: MVN f swap BIN: 1111 addr1 ; - -! These always update the condition code flags -: (CMP) >r f -rot r> S addr1 ; - -: TST BIN: 1000 (CMP) ; -: TEQ BIN: 1001 (CMP) ; -: CMP BIN: 1010 (CMP) ; -: CMN BIN: 1011 (CMP) ; - -! Multiply instructions -: (MLA) ( Rd Rm Rs Rn a -- ) - { - 21 - { register 12 } - { register 8 } - { register 0 } - { register 16 } - { 1 7 } - { 1 4 } - } sinsn ; - -: MUL ( Rd Rm Rs -- ) f 0 (MLA) ; -: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ; - -: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- ) - { - { 1 23 } - 22 - 21 - { register 8 } - { register 0 } - { register 16 } - { register 12 } - { 1 7 } - { 1 4 } - } sinsn ; - -: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ; -: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ; - -! Miscellaneous arithmetic instructions -: CLZ ( Rd Rm -- ) - { - { 1 24 } - { 1 22 } - { 1 21 } - { BIN: 111 16 } - { BIN: 1111 8 } - { 1 4 } - { register 0 } - { register 12 } - } sinsn ; - -! Status register acess instructions - -! Load and store instructions -GENERIC: addressing-mode-2 ( addressing-mode -- n ) - -TUPLE: addressing p u w ; -: ( delegate p u w -- addressing ) - { - set-delegate - set-addressing-p - set-addressing-u - set-addressing-w - } addressing construct ; - -M: addressing addressing-mode-2 - { - addressing-p addressing-u addressing-w delegate - } get-slots addressing-mode-2 - { 0 21 23 24 } bitfield ; - -M: integer addressing-mode-2 ; - -M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ; - -! Offset -: <+> 1 1 0 ; -: <-> 1 0 0 ; - -! Pre-indexed -: 1 1 1 ; -: 1 0 1 ; - -! Post-indexed -: <+!> 0 1 0 ; -: <-!> 0 0 0 ; - -: addr2 ( Rd Rn addressing-mode b l -- ) - { - { 1 26 } - 20 - 22 - { addressing-mode-2 0 } - { register 16 } - { register 12 } - } insn ; - -: LDR 0 1 addr2 ; -: LDRB 1 1 addr2 ; -: STR 0 0 addr2 ; -: STRB 1 0 addr2 ; - -! We might have to simulate these instructions since older ARM -! chips don't have them. -SYMBOL: have-BX? -SYMBOL: have-BLX? - -GENERIC# (BX) 1 ( Rm l -- ) - -M: register (BX) ( Rm l -- ) - { - { 1 24 } - { 1 21 } - { BIN: 1111 16 } - { BIN: 1111 12 } - { BIN: 1111 8 } - 5 - { 1 4 } - { register 0 } - } insn ; - -M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ; - -M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ; - -: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ; - -: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ; - -! More load and store instructions -GENERIC: addressing-mode-3 ( addressing-mode -- n ) - -: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ; - -M: addressing addressing-mode-3 - [ addressing-p ] keep - [ addressing-u ] keep - [ addressing-w ] keep - delegate addressing-mode-3 - { 0 21 23 24 } bitfield ; - -M: integer addressing-mode-3 - b>n/n { - ! { 1 24 } - { 1 22 } - { 1 7 } - { 1 4 } - 0 - 8 - } bitfield ; - -M: object addressing-mode-3 - shifter-op { - ! { 1 24 } - { 1 7 } - { 1 4 } - 0 - } bitfield ; - -: addr3 ( Rn Rd addressing-mode h l s -- ) - { - 6 - 20 - 5 - { addressing-mode-3 0 } - { register 16 } - { register 12 } - } insn ; - -: LDRH 1 1 0 addr3 ; -: LDRSB 0 1 1 addr3 ; -: LDRSH 1 1 1 addr3 ; -: STRH 1 0 0 addr3 ; - -! Load and store multiple instructions - -! Semaphore instructions - -! Exception-generating instructions diff --git a/basis/cpu/arm/assembler/authors.txt b/basis/cpu/arm/assembler/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/arm/assembler/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/authors.txt b/basis/cpu/arm/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/cpu/arm/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/bootstrap.factor b/basis/cpu/arm/bootstrap.factor deleted file mode 100755 index 793a488063..0000000000 --- a/basis/cpu/arm/bootstrap.factor +++ /dev/null @@ -1,119 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.arm.assembler math layouts words compiler.units ; -IN: bootstrap.arm - -! We generate ARM3 code -f have-BX? set - -4 \ cell set -big-endian off - -4 jit-code-format set - -: ds-reg R5 ; - -: word-reg R0 ; -: quot-reg R0 ; -: scan-reg R2 ; -: temp-reg R3 ; -: xt-reg R12 ; - -: stack-frame 16 bootstrap-cells ; - -: next-save stack-frame 2 bootstrap-cells - ; -: xt-save stack-frame 3 bootstrap-cells - ; -: array-save stack-frame 4 bootstrap-cells - ; -: scan-save stack-frame 5 bootstrap-cells - ; - -[ - temp-reg quot-reg quot-array@ <+> LDR ! load array - scan-reg temp-reg scan@ ADD ! initialize scan pointer -] { } make jit-setup set - -[ - LR SP 4 <-> STR ! save return address - SP SP stack-frame SUB - xt-reg SP xt-save <+> STR ! save XT - xt-reg stack-frame MOV - xt-reg SP next-save <+> STR ! save frame size - temp-reg SP array-save <+> STR ! save array -] { } make jit-prolog set - -[ - temp-reg scan-reg 4 LDR ! load literal and advance - temp-reg ds-reg 4 STR ! push literal -] { } make jit-push-literal set - -[ - temp-reg scan-reg 4 LDR ! load wrapper and advance - temp-reg dup wrapper@ <+> LDR ! load wrapped object - temp-reg ds-reg 4 STR ! push wrapped object -] { } make jit-push-wrapper set - -[ - R1 SP 4 SUB ! pass stack pointer to primitive -] { } make jit-word-primitive-jump set - -[ - R1 SP 4 SUB ! pass stack pointer to primitive -] { } make jit-word-primitive-call set - -: load-word-xt ( -- ) - word-reg scan-reg 4 LDR ! load word and advance - xt-reg word-reg word-xt@ <+> LDR ; - -: jit-call - scan-reg SP scan-save <+> STR ! save scan pointer - LR PC MOV ! save return address - xt-reg BX ! call - scan-reg SP scan-save <+> LDR ! restore scan pointer - ; - -: jit-jump - xt-reg BX ; - -[ load-word-xt jit-call ] { } make jit-word-call set - -[ load-word-xt jit-jump ] { } make jit-word-jump set - -: load-quot-xt - xt-reg quot-reg quot-xt@ <+> LDR ; - -: load-branch - temp-reg ds-reg 4 <-!> LDR ! pop boolean - temp-reg \ f tag-number CMP ! compare it with f - quot-reg scan-reg MOV ! point quot-reg at false branch - quot-reg dup 4 EQ ADD ! point quot-reg at true branch - quot-reg dup 4 <+> LDR ! load the branch - scan-reg dup 12 ADD ! advance scan pointer - load-quot-xt - ; - -[ - load-branch jit-jump -] { } make jit-if-jump set - -[ - load-branch jit-call -] { } make jit-if-call set - -[ - temp-reg ds-reg 4 <-!> LDR ! pop index - temp-reg dup 1 MOV ! turn it into an array offset - scan-reg dup 4 <+> LDR ! load array - temp-reg dup scan-reg ADD ! compute quotation location - quot-reg temp-reg array-start <+> LDR ! load quotation - load-quot-xt - jit-jump -] { } make jit-dispatch set - -[ - SP SP stack-frame ADD ! pop stack frame - LR SP 4 <-> LDR ! load return address -] { } make jit-epilog set - -[ LR BX ] { } make jit-return set - -[ "bootstrap.arm" forget-vocab ] with-compilation-unit diff --git a/basis/cpu/arm/intrinsics/authors.txt b/basis/cpu/arm/intrinsics/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/cpu/arm/intrinsics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/cpu/arm/intrinsics/intrinsics.factor b/basis/cpu/arm/intrinsics/intrinsics.factor deleted file mode 100755 index e9902888eb..0000000000 --- a/basis/cpu/arm/intrinsics/intrinsics.factor +++ /dev/null @@ -1,462 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.architecture cpu.arm.assembler -cpu.arm.architecture cpu.arm.allot kernel kernel.private math -math.private namespaces sequences words -quotations byte-arrays hashtables.private hashtables generator -generator.registers generator.fixup sequences.private sbufs -sbufs.private vectors vectors.private system -classes.tuple.private layouts strings.private slots.private ; -IN: cpu.arm.intrinsics - -: %slot-literal-known-tag - "val" operand - "obj" operand - "n" get cells - "obj" get operand-tag - <+/-> ; - -: %slot-literal-any-tag - "scratch" operand "obj" operand %untag - "val" operand "scratch" operand "n" get cells <+> ; - -: %slot-any - "scratch" operand "obj" operand %untag - "n" operand dup 1 MOV - "val" operand "scratch" operand "n" operand <+> ; - -\ slot { - ! Slot number is literal and the tag is known - { - [ %slot-literal-known-tag LDR ] H{ - { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } } - { +scratch+ { { f "val" } } } - { +output+ { "val" } } - } - } - ! Slot number is literal - { - [ %slot-literal-any-tag LDR ] H{ - { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } { f "val" } } } - { +output+ { "val" } } - } - } - ! Slot number in a register - { - [ %slot-any LDR ] H{ - { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "val" } { f "scratch" } } } - { +output+ { "val" } } - { +clobber+ { "n" } } - } - } -} define-intrinsics - -: %write-barrier ( -- ) - "val" get operand-immediate? "obj" get fresh-object? or [ - "cards_offset" f R12 %alien-global - "scratch" operand R12 "obj" operand card-bits ADD - "val" operand "scratch" operand 0 <+> LDRB - "val" operand dup card-mark ORR - "val" operand "scratch" operand 0 <+> STRB - ] unless ; - -\ set-slot { - ! Slot number is literal and tag is known - { - [ %slot-literal-known-tag STR %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "val" } } - } - } - ! Slot number is literal - { - [ %slot-literal-any-tag STR %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "val" } } - } - } - ! Slot number is in a register - { - [ %slot-any STR %write-barrier ] H{ - { +input+ { { f "val" } { f "obj" } { f "n" } } } - { +scratch+ { { f "scratch" } } } - { +clobber+ { "val" "n" } } - } - } -} define-intrinsics - -: fixnum-op ( op -- quot ) - [ "out" operand "x" operand "y" operand ] swap add ; - -: fixnum-register-op ( op -- pair ) - fixnum-op H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } 2array ; - -: fixnum-value-op ( op -- pair ) - fixnum-op H{ - { +input+ { { f "x" } { [ small-tagged? ] "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - } 2array ; - -: define-fixnum-op ( word op -- ) - [ fixnum-value-op ] keep fixnum-register-op 2array - define-intrinsics ; - -{ - { fixnum+fast ADD } - { fixnum-fast SUB } - { fixnum-bitand AND } - { fixnum-bitor ORR } - { fixnum-bitxor EOR } -} [ - first2 define-fixnum-op -] each - -\ fixnum-bitnot [ - "x" operand dup MVN - "x" operand dup %untag -] H{ - { +input+ { { f "x" } } } - { +output+ { "x" } } -} define-intrinsic - -\ fixnum*fast [ - "out" operand "y" operand %untag-fixnum - "out" operand "x" operand "out" operand MUL -] H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ fixnum-shift [ - "out" operand "x" operand "y" get neg MOV - ! Mask off low bits - "out" operand dup %untag -] H{ - { +input+ { { f "x" } { [ -31 0 between? ] "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -: %untag-fixnums ( seq -- ) - [ dup %untag-fixnum ] unique-operands ; - -: overflow-check ( insn -- ) - [ - "end" define-label - [ "out" operand "x" operand "y" operand roll S execute ] keep - "end" get VC B - { "x" "y" } %untag-fixnums - "x" operand "x" operand "y" operand roll execute - "out" get "x" get %allot-bignum-signed-1 - "end" resolve-label - ] with-scope ; inline - -: overflow-template ( word insn -- ) - [ overflow-check ] curry H{ - { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } - { +clobber+ { "x" "y" } } - } define-intrinsic ; - -\ fixnum+ \ ADD overflow-template -\ fixnum- \ SUB overflow-template - -\ fixnum>bignum [ - "x" operand dup %untag-fixnum - "out" get "x" get %allot-bignum-signed-1 -] H{ - { +input+ { { f "x" } } } - { +scratch+ { { f "out" } } } - { +clobber+ { "x" } } - { +output+ { "out" } } -} define-intrinsic - -\ bignum>fixnum [ - "end" define-label - "x" operand dup %untag - "y" operand "x" operand cell <+> LDR - ! if the length is 1, its just the sign and nothing else, - ! so output 0 - "y" operand 1 v>operand CMP - "y" operand 0 EQ MOV - "end" get EQ B - ! load the value - "y" operand "x" operand 3 cells <+> LDR - ! load the sign - "x" operand "x" operand 2 cells <+> LDR - ! is the sign negative? - "x" operand 0 CMP - ! Negate the value - "y" operand "y" operand 0 NE RSB - "y" operand dup %tag-fixnum - "end" resolve-label -] H{ - { +input+ { { f "x" } } } - { +scratch+ { { f "y" } } } - { +clobber+ { "x" } } - { +output+ { "y" } } -} define-intrinsic - -: fixnum-jump ( op -- quo ) - [ "x" operand "y" operand CMP ] swap - 1quotation [ B ] 3append ; - -: fixnum-register-jump ( op -- pair ) - fixnum-jump { { f "x" } { f "y" } } 2array ; - -: fixnum-value-jump ( op -- pair ) - fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ; - -: define-fixnum-jump ( word op -- ) - [ fixnum-value-jump ] keep fixnum-register-jump - 2array define-if-intrinsics ; - -{ - { fixnum< LT } - { fixnum<= LE } - { fixnum> GT } - { fixnum>= GE } - { eq? EQ } -} [ - first2 define-fixnum-jump -] each - -\ tag [ - "out" operand "in" operand tag-mask get AND - "out" operand dup %tag-fixnum -] H{ - { +input+ { { f "in" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ type [ - ! Get the tag - "out" operand "obj" operand tag-mask get AND - ! Compare with object tag number (3). - "out" operand object tag-number CMP - ! Tag the tag if it is not equal to 3 - "out" operand dup NE %tag-fixnum - ! Load the object header if tag is equal to 3 - "out" operand "obj" operand object tag-number <-> EQ LDR -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ class-hash [ - "end" define-label - ! Get the tag - "out" operand "obj" operand tag-mask get AND - ! Compare with tuple tag number (2). - "out" operand tuple tag-number CMP - "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR - "out" operand dup class-hash-offset <+/-> EQ LDR - "end" get EQ B - ! Compare with object tag number (3). - "out" operand object tag-number CMP - "out" operand "obj" operand object tag-number <-> EQ LDR - ! Tag the tag - "out" operand dup NE %tag-fixnum - "end" resolve-label -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -: userenv ( reg -- ) - #! Load the userenv pointer in a register. - "userenv" f rot compile-dlsym ; - -\ getenv [ - "n" operand dup 1 MOV - "x" operand userenv - "x" operand "x" operand "n" operand <+> LDR -] H{ - { +input+ { { f "n" } } } - { +scratch+ { { f "x" } } } - { +output+ { "x" } } - { +clobber+ { "n" } } -} define-intrinsic - -\ setenv [ - "n" operand dup 1 MOV - "x" operand userenv - "val" operand "x" operand "n" operand <+> STR -] H{ - { +input+ { { f "val" } { f "n" } } } - { +scratch+ { { f "x" } } } - { +clobber+ { "n" } } -} define-intrinsic - -: %set-slot R11 swap cells <+> STR ; - -: %store-length - R12 "n" operand MOV - R12 1 %set-slot ; - -: %fill-array swap 2 + %set-slot ; - -\ [ - tuple "n" get 2 + cells %allot - %store-length - ! Store class - "class" operand 2 %set-slot - ! Zero out the rest of the tuple - "initial" operand f v>operand MOV - "n" get 1- [ 1+ "initial" operand %fill-array ] each - "out" get tuple %store-tagged -] H{ - { +input+ { { f "class" } { [ inline-array? ] "n" } } } - { +scratch+ { { f "out" } { f "initial" } } } - { +output+ { "out" } } -} define-intrinsic - -\ [ - array "n" get 2 + cells %allot - %store-length - ! Store initial element - "n" get [ "initial" operand %fill-array ] each - "out" get object %store-tagged -] H{ - { +input+ { { [ inline-array? ] "n" } { f "initial" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ [ - byte-array "n" get 2 cells + %allot - %store-length - ! Store initial element - R12 0 MOV - "n" get cell align cell /i [ R12 %fill-array ] each - "out" get object %store-tagged -] H{ - { +input+ { { [ inline-array? ] "n" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ [ - ratio 3 cells %allot - "numerator" operand 1 %set-slot - "denominator" operand 2 %set-slot - "out" get ratio %store-tagged -] H{ - { +input+ { { f "numerator" } { f "denominator" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ [ - complex 3 cells %allot - "real" operand 1 %set-slot - "imaginary" operand 2 %set-slot - ! Store tagged ptr in reg - "out" get complex %store-tagged -] H{ - { +input+ { { f "real" } { f "imaginary" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ [ - wrapper 2 cells %allot - "obj" operand 1 %set-slot - ! Store tagged ptr in reg - "out" get object %store-tagged -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -! Alien intrinsics -: %alien-accessor ( quot -- ) - "offset" operand dup %untag-fixnum - "offset" operand dup "alien" operand ADD - "value" operand "offset" operand 0 <+> roll call ; inline - -: alien-integer-get-template - H{ - { +input+ { - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "value" } } } - { +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 } - } } - { +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 [ LDRB ] -\ set-alien-unsigned-1 [ STRB ] -define-alien-integer-intrinsics - -: alien-cell-template - H{ - { +input+ { - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { unboxed-alien "value" } } } - { +output+ { "value" } } - { +clobber+ { "offset" } } - } ; - -\ alien-cell -[ [ LDR ] %alien-accessor ] -alien-cell-template define-intrinsic - -: set-alien-cell-template - H{ - { +input+ { - { unboxed-c-ptr "value" pinned-c-ptr } - { unboxed-c-ptr "alien" c-ptr } - { f "offset" fixnum } - } } - { +clobber+ { "offset" } } - } ; - -\ set-alien-cell -[ [ STR ] %alien-accessor ] -set-alien-cell-template define-intrinsic diff --git a/basis/cpu/arm/summary.txt b/basis/cpu/arm/summary.txt deleted file mode 100644 index f3e46d9f43..0000000000 --- a/basis/cpu/arm/summary.txt +++ /dev/null @@ -1 +0,0 @@ -ARM3 compiler backend diff --git a/basis/cpu/arm/tags.txt b/basis/cpu/arm/tags.txt deleted file mode 100644 index 86a7c8e637..0000000000 --- a/basis/cpu/arm/tags.txt +++ /dev/null @@ -1 +0,0 @@ -compiler diff --git a/basis/cpu/ppc/allot/tags.txt b/basis/cpu/ppc/allot/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/allot/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/architecture/tags.txt b/basis/cpu/ppc/architecture/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/architecture/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/assembler/backend/tags.txt b/basis/cpu/ppc/assembler/backend/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/assembler/backend/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/intrinsics/tags.txt b/basis/cpu/ppc/intrinsics/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/intrinsics/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/tags.txt b/basis/cpu/ppc/tags.txt index 86a7c8e637..8e66660f70 100644 --- a/basis/cpu/ppc/tags.txt +++ b/basis/cpu/ppc/tags.txt @@ -1 +1,2 @@ +unportable compiler diff --git a/basis/cpu/x86/32/tags.txt b/basis/cpu/x86/32/tags.txt index 86a7c8e637..8e66660f70 100644 --- a/basis/cpu/x86/32/tags.txt +++ b/basis/cpu/x86/32/tags.txt @@ -1 +1,2 @@ +unportable compiler diff --git a/basis/cpu/x86/64/tags.txt b/basis/cpu/x86/64/tags.txt index 86a7c8e637..8e66660f70 100644 --- a/basis/cpu/x86/64/tags.txt +++ b/basis/cpu/x86/64/tags.txt @@ -1 +1,2 @@ +unportable compiler diff --git a/basis/cpu/x86/allot/tags.txt b/basis/cpu/x86/allot/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/allot/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/x86/architecture/tags.txt b/basis/cpu/x86/architecture/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/architecture/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/x86/assembler/syntax/tags.txt b/basis/cpu/x86/assembler/syntax/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/assembler/syntax/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/x86/intrinsics/tags.txt b/basis/cpu/x86/intrinsics/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/intrinsics/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/x86/sse2/tags.txt b/basis/cpu/x86/sse2/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/sse2/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 7879f3fbb6..284d206da4 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -86,3 +86,7 @@ M:: disjoint-set equate ( a b disjoint-set -- ) [ swap ] [ over disjoint-set inc-rank ] [ ] branch disjoint-set link-sets ] if ; + +M: disjoint-set clone + [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ + disjoint-set boa ; diff --git a/basis/editors/editpadpro/tags.txt b/basis/editors/editpadpro/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/editpadpro/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/editplus/tags.txt b/basis/editors/editplus/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/editplus/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/emacs/tags.txt b/basis/editors/emacs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/emacs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/emeditor/tags.txt b/basis/editors/emeditor/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/emeditor/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/gvim/backend/tags.txt b/basis/editors/gvim/backend/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/gvim/backend/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/gvim/tags.txt b/basis/editors/gvim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/gvim/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/gvim/unix/tags.txt b/basis/editors/gvim/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/gvim/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/gvim/windows/tags.txt b/basis/editors/gvim/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/gvim/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/jedit/tags.txt b/basis/editors/jedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/jedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/notepadpp/tags.txt b/basis/editors/notepadpp/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/notepadpp/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/scite/tags.txt b/basis/editors/scite/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/scite/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/ted-notepad/tags.txt b/basis/editors/ted-notepad/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/ted-notepad/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textmate/tags.txt b/basis/editors/textmate/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textmate/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textwrangler/tags.txt b/basis/editors/textwrangler/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textwrangler/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/ultraedit/tags.txt b/basis/editors/ultraedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/ultraedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/vim/generate-syntax/tags.txt b/basis/editors/vim/generate-syntax/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/vim/generate-syntax/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/vim/tags.txt b/basis/editors/vim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/vim/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/wordpad/tags.txt b/basis/editors/wordpad/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/wordpad/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/backend/tags.txt b/basis/io/unix/backend/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/backend/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/bsd/tags.txt b/basis/io/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/epoll/tags.txt b/basis/io/unix/epoll/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/epoll/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/tags.txt b/basis/io/unix/files/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/unique/tags.txt b/basis/io/unix/files/unique/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/unique/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/freebsd/tags.txt b/basis/io/unix/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/kqueue/tags.txt b/basis/io/unix/kqueue/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/kqueue/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/launcher/parser/tags.txt b/basis/io/unix/launcher/parser/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/launcher/parser/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/launcher/tags.txt b/basis/io/unix/launcher/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/launcher/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/linux/monitors/tags.txt b/basis/io/unix/linux/monitors/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/linux/monitors/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/linux/tags.txt b/basis/io/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/macosx/monitors/tags.txt b/basis/io/unix/macosx/monitors/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/macosx/monitors/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/macosx/tags.txt b/basis/io/unix/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/mmap/tags.txt b/basis/io/unix/mmap/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/mmap/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/netbsd/tags.txt b/basis/io/unix/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/openbsd/tags.txt b/basis/io/unix/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/pipes/tags.txt b/basis/io/unix/pipes/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/pipes/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/select/tags.txt b/basis/io/unix/select/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/select/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/sockets/secure/tags.txt b/basis/io/unix/sockets/secure/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/sockets/secure/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/sockets/tags.txt b/basis/io/unix/sockets/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/sockets/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/tags.txt b/basis/io/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/files/tags.txt b/basis/io/windows/files/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/files/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/files/unique/tags.txt b/basis/io/windows/files/unique/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/files/unique/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/launcher/tags.txt b/basis/io/windows/launcher/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/launcher/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/mmap/tags.txt b/basis/io/windows/mmap/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/mmap/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/backend/tags.txt b/basis/io/windows/nt/backend/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/backend/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/files/tags.txt b/basis/io/windows/nt/files/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/files/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/launcher/tags.txt b/basis/io/windows/nt/launcher/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/launcher/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/monitors/tags.txt b/basis/io/windows/nt/monitors/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/monitors/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/pipes/tags.txt b/basis/io/windows/nt/pipes/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/pipes/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/privileges/tags.txt b/basis/io/windows/nt/privileges/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/privileges/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/sockets/tags.txt b/basis/io/windows/nt/sockets/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/sockets/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/nt/tags.txt b/basis/io/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/privileges/tags.txt b/basis/io/windows/privileges/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/privileges/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/sockets/tags.txt b/basis/io/windows/sockets/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/windows/sockets/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/windows/tags.txt b/basis/io/windows/tags.txt index 8e1a55995e..02ec70f741 100644 --- a/basis/io/windows/tags.txt +++ b/basis/io/windows/tags.txt @@ -1 +1,2 @@ +unportable windows diff --git a/basis/random/unix/tags.txt b/basis/random/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/random/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/random/windows/tags.txt b/basis/random/windows/tags.txt index 8e1a55995e..02ec70f741 100644 --- a/basis/random/windows/tags.txt +++ b/basis/random/windows/tags.txt @@ -1 +1,2 @@ +unportable windows diff --git a/basis/tools/deploy/macosx/tags.txt b/basis/tools/deploy/macosx/tags.txt index ef1aab0d0e..660d511420 100644 --- a/basis/tools/deploy/macosx/tags.txt +++ b/basis/tools/deploy/macosx/tags.txt @@ -1 +1,2 @@ +unportable tools diff --git a/basis/tools/deploy/unix/tags.txt b/basis/tools/deploy/unix/tags.txt index ef1aab0d0e..660d511420 100644 --- a/basis/tools/deploy/unix/tags.txt +++ b/basis/tools/deploy/unix/tags.txt @@ -1 +1,2 @@ +unportable tools diff --git a/basis/tools/deploy/windows/tags.txt b/basis/tools/deploy/windows/tags.txt index 6eee6b9766..b58a515ed8 100644 --- a/basis/tools/deploy/windows/tags.txt +++ b/basis/tools/deploy/windows/tags.txt @@ -1,2 +1,3 @@ +unportable windows tools diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 442e15935c..6328a3d06d 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -232,39 +232,15 @@ M: vocab-link summary vocab-summary ; MEMO: all-vocabs-seq ( -- seq ) all-vocabs values concat ; -: dangerous? ( name -- ? ) - #! Hack - { - { [ "cpu." ?head ] [ t ] } - { [ "io.unix" ?head ] [ t ] } - { [ "io.windows" ?head ] [ t ] } - { [ "ui.x11" ?head ] [ t ] } - { [ "ui.windows" ?head ] [ t ] } - { [ "ui.cocoa" ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ "core-foundation" ?head ] [ t ] } - { [ "vocabs.loader.test" ?head ] [ t ] } - { [ "editors." ?head ] [ t ] } - { [ ".windows" ?tail ] [ t ] } - { [ ".unix" ?tail ] [ t ] } - { [ "unix" ?head ] [ t ] } - { [ ".linux" ?tail ] [ t ] } - { [ ".bsd" ?tail ] [ t ] } - { [ ".macosx" ?tail ] [ t ] } - { [ "windows." ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ ".test" ?tail ] [ t ] } - { [ "raptor" ?head ] [ t ] } - { [ dup "tools.deploy.app" = ] [ t ] } - [ f ] - } cond nip ; - -: filter-dangerous ( seq -- seq' ) - [ vocab-name dangerous? not ] filter ; +: unportable? ( name -- ? ) + vocab-tags "unportable" swap member? ; + +: filter-unportable ( seq -- seq' ) + [ vocab-name unportable? not ] filter ; : try-everything ( -- failures ) all-vocabs-seq - filter-dangerous + filter-unportable require-all ; : load-everything ( -- ) diff --git a/basis/unix/bsd/freebsd/tags.txt b/basis/unix/bsd/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/bsd/macosx/tags.txt b/basis/unix/bsd/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/bsd/netbsd/tags.txt b/basis/unix/bsd/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/bsd/openbsd/tags.txt b/basis/unix/bsd/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/bsd/tags.txt b/basis/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/kqueue/freebsd/tags.txt b/basis/unix/kqueue/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/kqueue/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/kqueue/macosx/tags.txt b/basis/unix/kqueue/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/kqueue/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/kqueue/netbsd/tags.txt b/basis/unix/kqueue/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/kqueue/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/kqueue/openbsd/tags.txt b/basis/unix/kqueue/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/kqueue/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/kqueue/tags.txt b/basis/unix/kqueue/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/kqueue/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/epoll/tags.txt b/basis/unix/linux/epoll/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/epoll/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/fs/tags.txt b/basis/unix/linux/fs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/fs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/if/tags.txt b/basis/unix/linux/if/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/if/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/ifreq/tags.txt b/basis/unix/linux/ifreq/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/ifreq/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/inotify/tags.txt b/basis/unix/linux/inotify/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/inotify/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/route/tags.txt b/basis/unix/linux/route/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/route/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/sockios/tags.txt b/basis/unix/linux/sockios/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/sockios/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/swap/tags.txt b/basis/unix/linux/swap/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/swap/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/linux/tags.txt b/basis/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/process/tags.txt b/basis/unix/process/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/process/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/solaris/tags.txt b/basis/unix/solaris/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/solaris/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/freebsd/32/tags.txt b/basis/unix/stat/freebsd/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/freebsd/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/freebsd/64/tags.txt b/basis/unix/stat/freebsd/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/freebsd/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/freebsd/tags.txt b/basis/unix/stat/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/linux/32/tags.txt b/basis/unix/stat/linux/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/linux/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/linux/64/tags.txt b/basis/unix/stat/linux/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/linux/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/linux/tags.txt b/basis/unix/stat/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/macosx/tags.txt b/basis/unix/stat/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/netbsd/32/tags.txt b/basis/unix/stat/netbsd/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/netbsd/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/netbsd/64/tags.txt b/basis/unix/stat/netbsd/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/netbsd/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/netbsd/tags.txt b/basis/unix/stat/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/openbsd/tags.txt b/basis/unix/stat/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/stat/tags.txt b/basis/unix/stat/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/stat/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/tags.txt b/basis/unix/tags.txt index bb863cf9a0..2320bdd648 100644 --- a/basis/unix/tags.txt +++ b/basis/unix/tags.txt @@ -1 +1,2 @@ +unportable bindings diff --git a/basis/unix/time/tags.txt b/basis/unix/time/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/time/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/freebsd/tags.txt b/basis/unix/types/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/linux/tags.txt b/basis/unix/types/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/macosx/tags.txt b/basis/unix/types/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/netbsd/32/tags.txt b/basis/unix/types/netbsd/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/netbsd/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/netbsd/64/tags.txt b/basis/unix/types/netbsd/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/netbsd/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/netbsd/tags.txt b/basis/unix/types/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/openbsd/tags.txt b/basis/unix/types/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/tags.txt b/basis/unix/types/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/types/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/advapi32/tags.txt b/basis/windows/advapi32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/advapi32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/ce/tags.txt b/basis/windows/ce/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/ce/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/com/syntax/tags.txt b/basis/windows/com/syntax/tags.txt index 49139bab66..71c5900baf 100644 --- a/basis/windows/com/syntax/tags.txt +++ b/basis/windows/com/syntax/tags.txt @@ -1,3 +1,4 @@ -windows -com -bindings +unportable +windows +com +bindings diff --git a/basis/windows/com/tags.txt b/basis/windows/com/tags.txt index 49139bab66..71c5900baf 100644 --- a/basis/windows/com/tags.txt +++ b/basis/windows/com/tags.txt @@ -1,3 +1,4 @@ -windows -com -bindings +unportable +windows +com +bindings diff --git a/basis/windows/com/wrapper/tags.txt b/basis/windows/com/wrapper/tags.txt index ffb665dc8f..71c5900baf 100644 --- a/basis/windows/com/wrapper/tags.txt +++ b/basis/windows/com/wrapper/tags.txt @@ -1,3 +1,4 @@ +unportable windows com bindings diff --git a/basis/windows/dinput/constants/tags.txt b/basis/windows/dinput/constants/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/dinput/constants/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/dinput/tags.txt b/basis/windows/dinput/tags.txt index 5aebfa6848..1431506222 100755 --- a/basis/windows/dinput/tags.txt +++ b/basis/windows/dinput/tags.txt @@ -1,2 +1,3 @@ +unportable windows bindings diff --git a/basis/windows/dragdrop-listener/tags.txt b/basis/windows/dragdrop-listener/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/dragdrop-listener/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/errors/tags.txt b/basis/windows/errors/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/errors/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/gdi32/tags.txt b/basis/windows/gdi32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/gdi32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/kernel32/tags.txt b/basis/windows/kernel32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/kernel32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/messages/tags.txt b/basis/windows/messages/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/messages/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/nt/tags.txt b/basis/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/ole32/tags.txt b/basis/windows/ole32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/ole32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/opengl32/tags.txt b/basis/windows/opengl32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/opengl32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/shell32/tags.txt b/basis/windows/shell32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/shell32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/tags.txt b/basis/windows/tags.txt index 5aebfa6848..1431506222 100644 --- a/basis/windows/tags.txt +++ b/basis/windows/tags.txt @@ -1,2 +1,3 @@ +unportable windows bindings diff --git a/basis/windows/time/tags.txt b/basis/windows/time/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/time/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/types/tags.txt b/basis/windows/types/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/types/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/user32/tags.txt b/basis/windows/user32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/user32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/winsock/tags.txt b/basis/windows/winsock/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/winsock/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/x11/windows/tags.txt b/basis/x11/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/x11/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/a/tags.txt b/core/vocabs/loader/test/a/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/a/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/b/tags.txt b/core/vocabs/loader/test/b/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/b/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/c/tags.txt b/core/vocabs/loader/test/c/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/c/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/d/tags.txt b/core/vocabs/loader/test/d/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/d/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/game-input/backend/dinput/tags.txt b/extra/game-input/backend/dinput/tags.txt index 70912457cb..9098dfdba4 100755 --- a/extra/game-input/backend/dinput/tags.txt +++ b/extra/game-input/backend/dinput/tags.txt @@ -1,3 +1,4 @@ +unportable input gamepads joysticks diff --git a/extra/game-input/backend/iokit/tags.txt b/extra/game-input/backend/iokit/tags.txt index b3bc4f873b..704b10bc4c 100644 --- a/extra/game-input/backend/iokit/tags.txt +++ b/extra/game-input/backend/iokit/tags.txt @@ -1,3 +1,4 @@ +unportable gamepads joysticks mac diff --git a/extra/hardware-info/linux/tags.txt b/extra/hardware-info/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/hardware-info/macosx/tags.txt b/extra/hardware-info/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/hardware-info/windows/tags.txt b/extra/hardware-info/windows/tags.txt index 8e1a55995e..02ec70f741 100644 --- a/extra/hardware-info/windows/tags.txt +++ b/extra/hardware-info/windows/tags.txt @@ -1 +1,2 @@ +unportable windows diff --git a/extra/micros/unix/tags.txt b/extra/micros/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/micros/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/micros/windows/tags.txt b/extra/micros/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/micros/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/openal/macosx/tags.txt b/extra/openal/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/openal/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/opengl/gl/macosx/tags.txt b/extra/opengl/gl/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/opengl/gl/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/opengl/gl/unix/tags.txt b/extra/opengl/gl/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/opengl/gl/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/opengl/gl/windows/tags.txt b/extra/opengl/gl/windows/tags.txt index 8e1a55995e..02ec70f741 100644 --- a/extra/opengl/gl/windows/tags.txt +++ b/extra/opengl/gl/windows/tags.txt @@ -1 +1,2 @@ +unportable windows diff --git a/extra/raptor/cron/tags.txt b/extra/raptor/cron/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/raptor/cron/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/raptor/tags.txt b/extra/raptor/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/raptor/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/ui/cocoa/tags.txt b/extra/ui/cocoa/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/ui/cocoa/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/ui/cocoa/tools/tags.txt b/extra/ui/cocoa/tools/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/ui/cocoa/tools/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/ui/cocoa/views/tags.txt b/extra/ui/cocoa/views/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/ui/cocoa/views/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/ui/windows/tags.txt b/extra/ui/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/ui/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/ui/x11/tags.txt b/extra/ui/x11/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/ui/x11/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/unmaintained/arm/4/4.factor b/unmaintained/arm/4/4.factor new file mode 100755 index 0000000000..0d317fd553 --- /dev/null +++ b/unmaintained/arm/4/4.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien arrays cpu.architecture cpu.arm.assembler +cpu.arm.architecture cpu.arm5.assembler kernel kernel.private +math math.private namespaces sequences words quotations +byte-arrays hashtables.private hashtables generator +generator.registers generator.fixup sequences.private +strings.private ; +IN: cpu.arm4 + +: (%char-slot) + "out" operand string-offset MOV + "out" operand dup "n" operand 2 ADD ; + +\ char-slot [ + (%char-slot) + "out" operand "obj" operand "out" operand <+> LDRH + "out" operand dup %tag-fixnum +] H{ + { +input+ { { f "n" } { f "obj" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ set-char-slot [ + "val" operand dup %untag-fixnum + (%char-slot) + "val" operand "obj" operand "out" operand <+> STRH +] H{ + { +input+ { { f "val" } { f "n" } { f "obj" } } } + { +scratch+ { { f "out" } } } + { +clobber+ { "val" } } +} define-intrinsic + +\ alien-signed-1 [ LDRSB ] +\ set-alien-signed-1 [ STRB ] +define-alien-integer-intrinsics + +\ alien-unsigned-2 [ LDRH ] +\ set-alien-unsigned-2 [ STRH ] +define-alien-integer-intrinsics + +\ alien-signed-2 [ LDRSH ] +\ set-alien-signed-2 [ STRH ] +define-alien-integer-intrinsics diff --git a/unmaintained/arm/4/authors.txt b/unmaintained/arm/4/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/4/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/4/summary.txt b/unmaintained/arm/4/summary.txt new file mode 100644 index 0000000000..7be5231690 --- /dev/null +++ b/unmaintained/arm/4/summary.txt @@ -0,0 +1 @@ +Additional compiler intrinsics for ARM4 diff --git a/unmaintained/arm/allot/allot.factor b/unmaintained/arm/allot/allot.factor new file mode 100755 index 0000000000..27a4676926 --- /dev/null +++ b/unmaintained/arm/allot/allot.factor @@ -0,0 +1,79 @@ +! Copyright (C) 2006, 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel cpu.architecture cpu.arm.assembler +cpu.arm.architecture namespaces math sequences +generator generator.registers generator.fixup system layouts +alien ; +IN: cpu.arm.allot + +: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ; + +: %allot ( header size -- ) + #! Store a pointer to 'size' bytes allocated from the + #! nursery in R11 + 8 align ! align the size + R12 load-zone-ptr ! nusery -> r12 + R11 R12 cell <+> LDR ! nursery.here -> r11 + R11 R11 pick ADD ! increment r11 + R11 R12 cell <+> STR ! r11 -> nursery.here + R11 R11 rot SUB ! old value + R12 swap type-number tag-fixnum MOV ! compute header + R12 R11 0 <+> STR ! store header + ; + +: %store-tagged ( reg tag -- ) + >r dup fresh-object v>operand R11 r> tag-number ORR ; + +: %allot-bignum ( #digits -- ) + #! 1 cell header, 1 cell length, 1 cell sign, + digits + #! length is the # of digits + sign + bignum over 3 + cells %allot + R12 swap 1+ v>operand MOV ! compute the length + R12 R11 cell <+> STR ! store the length + ; + +: %allot-bignum-signed-1 ( dst src -- ) + #! on entry, reg is a 30-bit quantity sign-extended to + #! 32-bits. + #! exits with tagged ptr to bignum in reg. + [ + "end" define-label + ! is it zero? + dup v>operand 0 CMP + 0 >bignum pick EQ load-literal + "end" get EQ B + ! ! it is non-zero + 1 %allot-bignum + ! is the fixnum negative? + dup v>operand 0 CMP + ! negative sign + R12 1 LT MOV + ! negate fixnum + dup v>operand dup 0 LT RSB + ! positive sign + R12 0 GE MOV + ! store sign + R12 R11 2 cells <+> STR + ! store the number + v>operand R11 3 cells <+> STR + ! tag the bignum, store it in reg + bignum %store-tagged + "end" resolve-label + ] with-scope ; + +M: arm-backend %box-alien ( dst src -- ) + "end" define-label + dup v>operand 0 CMP + over v>operand f v>operand EQ MOV + "end" get EQ B + alien 4 cells %allot + ! Store offset + v>operand R11 3 cells <+> STR + R12 f v>operand MOV + ! Store expired slot + R12 R11 1 cells <+> STR + ! Store underlying-alien slot + R12 R11 2 cells <+> STR + ! Store tagged ptr in reg + object %store-tagged + "end" resolve-label ; diff --git a/unmaintained/arm/allot/authors.txt b/unmaintained/arm/allot/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/allot/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/architecture/architecture.factor b/unmaintained/arm/architecture/architecture.factor new file mode 100755 index 0000000000..563dd10bc4 --- /dev/null +++ b/unmaintained/arm/architecture/architecture.factor @@ -0,0 +1,370 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays cpu.arm.assembler compiler +kernel kernel.private math namespaces words words.private +generator.registers generator.fixup generator cpu.architecture +system layouts ; +IN: cpu.arm.architecture + +TUPLE: arm-backend ; + +! ARM register assignments: +! R0-R4, R7-R10 integer vregs +! R11, R12 temporary +! R5 data stack +! R6 retain stack +! R7 primitives + +: ds-reg R5 ; inline +: rs-reg R6 ; inline + +M: temp-reg v>operand drop R12 ; + +M: int-regs return-reg drop R0 ; +M: int-regs param-regs drop { R0 R1 R2 R3 } ; +M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ; + +! No FPU support yet +M: float-regs param-regs drop { } ; +M: float-regs vregs drop { } ; + +: <+/-> dup 0 < [ neg <-> ] [ <+> ] if ; + +GENERIC: loc>operand ( loc -- reg addressing ) +M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap <+/-> ; +M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ; + +: load-cell ( reg -- ) + [ + "end" define-label + ! Load target address + PC 0 <+> LDR + ! Skip an instruction + "end" get B + ! The target address + 0 , + ! Continue here + "end" resolve-label + ] with-scope ; + +: call-cell ( -- ) + ! Compute return address; we skip 3 instructions + LR PC 8 ADD + ! Load target address + R12 PC 0 <+> LDR + ! Jump to target address + R12 BX + ! The target address + 0 , ; + +M: arm-backend load-indirect ( obj reg -- ) + tuck load-cell rc-absolute-cell rel-literal + dup 0 <+> LDR ; + +M: immediate load-literal + over v>operand small-enough? [ + [ v>operand ] bi@ swap MOV + ] [ + v>operand load-indirect + ] if ; + +: lr-save ( n -- i ) cell - ; +: next-save ( n -- i ) 2 cells - ; +: xt-save ( n -- i ) 3 cells - ; +: factor-area-size 5 cells ; + +M: arm-backend stack-frame ( n -- i ) + factor-area-size + 8 align ; + +M: arm-backend %save-word-xt ( -- ) + R12 PC 9 cells SUB ; + +M: arm-backend %save-dispatch-xt ( -- ) + R12 PC 2 cells SUB ; + +M: arm-backend %prologue ( n -- ) + SP SP pick SUB + R11 over MOV + R11 SP pick next-save <+> STR + R12 SP pick xt-save <+> STR + LR SP rot lr-save <+> STR ; + +M: arm-backend %epilogue ( n -- ) + LR SP pick lr-save <+> LDR + SP SP rot ADD ; + +: compile-dlsym ( symbol dll reg -- ) + load-cell rc-absolute rel-dlsym ; + +: %alien-global ( symbol dll reg -- ) + [ compile-dlsym ] keep dup 0 <+> LDR ; + +M: arm-backend %profiler-prologue ( -- ) + #! We can clobber R0 here since it is undefined at the start + #! of a word. + R12 load-indirect + R0 R12 profile-count-offset <+> LDR + R0 R0 1 v>operand ADD + R0 R12 profile-count-offset <+> STR ; + +M: arm-backend %call-label ( label -- ) BL ; + +M: arm-backend %jump-label ( label -- ) B ; + +: %prepare-primitive ( -- ) + #! Save stack pointer to stack_chain->callstack_top, load XT + R1 SP 4 SUB ; + +M: arm-backend %call-primitive ( word -- ) + %prepare-primitive + call-cell rc-absolute-cell rel-word ; + +M: arm-backend %jump-primitive ( word -- ) + %prepare-primitive + ! Load target address + R12 PC 0 <+> LDR + ! Jump to target address + R12 BX + ! The target address + 0 , rc-absolute-cell rel-word ; + +M: arm-backend %jump-t ( label -- ) + "flag" operand f v>operand CMP NE B ; + +: (%dispatch) ( word-table# -- ) + #! Load jump table target address into reg. + "scratch" operand PC "n" operand 1 ADD + "scratch" operand dup 0 <+> LDR + rc-indirect-arm rel-dispatch + "scratch" operand dup compiled-header-size ADD ; + +M: arm-backend %call-dispatch ( word-table# -- ) + [ + (%dispatch) + "scratch" operand BLX + ] H{ + { +input+ { { f "n" } } } + { +scratch+ { { f "scratch" } } } + } with-template ; + +M: arm-backend %jump-dispatch ( word-table# -- ) + [ + %epilogue-later + (%dispatch) + "scratch" operand BX + ] H{ + { +input+ { { f "n" } } } + { +scratch+ { { f "scratch" } } } + } with-template ; + +M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ; + +M: arm-backend %unwind drop %return ; + +M: arm-backend %peek >r v>operand r> loc>operand LDR ; + +M: arm-backend %replace >r v>operand r> loc>operand STR ; + +: (%inc) ( n reg -- ) + dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ; + +M: arm-backend %inc-d ( n -- ) ds-reg (%inc) ; + +M: arm-backend %inc-r ( n -- ) rs-reg (%inc) ; + +: stack@ SP swap <+> ; + +M: int-regs %save-param-reg drop swap stack@ STR ; + +M: int-regs %load-param-reg drop swap stack@ LDR ; + +M: stack-params %save-param-reg + drop + R12 swap stack-frame* + stack@ LDR + R12 swap stack@ STR ; + +M: stack-params %load-param-reg + drop + R12 rot stack@ LDR + R12 swap stack@ STR ; + +M: arm-backend %prepare-unbox ( -- ) + ! First parameter is top of stack + R0 R5 4 <-!> LDR ; + +M: arm-backend %unbox ( n reg-class func -- ) + ! Value must be in R0. + ! Call the unboxer + f %alien-invoke + ! Store the return value on the C stack + over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; + +M: arm-backend %unbox-long-long ( n func -- ) + ! Value must be in R0:R1. + ! Call the unboxer + f %alien-invoke + ! Store the return value on the C stack + [ + R0 over stack@ STR + R1 swap cell + stack@ STR + ] when* ; + +M: arm-backend %unbox-small-struct ( size -- ) + #! Alien must be in R0. + drop + "alien_offset" f %alien-invoke + ! Load first cell + R0 R0 0 <+> LDR ; + +M: arm-backend %unbox-large-struct ( n size -- ) + #! Alien must be in R0. + ! Compute destination address + R1 SP roll ADD + R2 swap MOV + ! Copy the struct to the stack + "to_value_struct" f %alien-invoke ; + +M: arm-backend %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: arm-backend %box-long-long ( n func -- ) + >r [ + R0 over stack@ LDR + R1 swap cell + stack@ LDR + ] when* r> f %alien-invoke ; + +M: arm-backend %box-small-struct ( size -- ) + #! Box a 4-byte struct returned in R0. + R2 swap MOV + "box_small_struct" f %alien-invoke ; + +: temp@ stack-frame* factor-area-size - swap - ; + +: struct-return@ ( size n -- n ) + [ + stack-frame* + + ] [ + stack-frame* factor-area-size - swap - + ] ?if ; + +M: arm-backend %prepare-box-struct ( size -- ) + ! Compute target address for value struct return + R0 SP rot f struct-return@ ADD + ! Store it as the first parameter + R0 0 stack@ STR ; + +M: arm-backend %box-large-struct ( n size -- ) + ! Compute destination address + [ swap struct-return@ ] keep + R0 SP roll ADD + R1 swap MOV + ! Copy the struct from the C stack + "box_value_struct" f %alien-invoke ; + +M: arm-backend struct-small-enough? ( size -- ? ) + wince? [ drop f ] [ 4 <= ] if ; + +M: arm-backend %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 R12 %alien-global + SP R12 0 <+> STR + ds-reg R12 8 <+> STR + rs-reg R12 12 <+> STR ; + +M: arm-backend %alien-invoke ( symbol dll -- ) + call-cell rc-absolute-cell rel-dlsym ; + +M: arm-backend %prepare-alien-indirect ( -- ) + "unbox_alien" f %alien-invoke + R0 SP cell temp@ <+> STR ; + +M: arm-backend %alien-indirect ( -- ) + R12 SP cell temp@ <+> LDR + R12 BLX ; + +M: arm-backend %alien-callback ( quot -- ) + R0 load-indirect + "c_to_factor" f %alien-invoke ; + +M: arm-backend %callback-value ( ctype -- ) + ! Save top of data stack + %prepare-unbox + R0 SP cell temp@ <+> STR + ! Restore data/call/retain stacks + "unnest_stacks" f %alien-invoke + ! Place former top of data stack in R0 + R0 SP cell temp@ <+> LDR + ! Unbox R0 + unbox-return ; + +M: arm-backend %cleanup ( alien-node -- ) drop ; + +: %untag ( dest src -- ) BIN: 111 BIC ; + +: %untag-fixnum ( dest src -- ) tag-bits get MOV ; + +: %tag-fixnum ( dest src -- ) tag-bits get MOV ; + +M: arm-backend value-structs? t ; + +M: arm-backend small-enough? ( n -- ? ) 0 255 between? ; + +M: long-long-type c-type-stack-align? drop wince? not ; + +M: arm-backend fp-shadows-int? ( -- ? ) f ; + +! Alien intrinsics +M: arm-backend %unbox-byte-array ( dst src -- ) + [ v>operand ] bi@ byte-array-offset ADD ; + +M: arm-backend %unbox-alien ( dst src -- ) + [ v>operand ] bi@ alien-offset <+> LDR ; + +M: arm-backend %unbox-f ( dst src -- ) + drop v>operand 0 MOV ; + +M: arm-backend %unbox-any-c-ptr ( dst src -- ) + #! We need three registers here. R11 and R12 are reserved + #! temporary registers. The third one is R14, which we have + #! to save/restore. + "end" define-label + "start" define-label + ! Save R14. + R14 SP 4 <-> STR + ! Address is computed in R11 + R11 0 MOV + ! Load object into R12 + R12 swap v>operand MOV + ! We come back here with displaced aliens + "start" resolve-label + ! Is the object f? + R12 f v>operand CMP + ! If so, done + "end" get EQ B + ! Is the object an alien? + R14 R12 header-offset <+/-> LDR + R14 alien type-number tag-fixnum CMP + ! Add byte array address to address being computed + R11 R11 R12 NE ADD + ! Add an offset to start of byte array's data area + R11 R11 byte-array-offset NE ADD + "end" get NE B + ! If alien, load the offset + R14 R12 alien-offset <+/-> LDR + ! Add it to address being computed + R11 R11 R14 ADD + ! Now recurse on the underlying alien + R12 R12 underlying-alien-offset <+/-> LDR + "start" get B + "end" resolve-label + ! Done, store address in destination register + v>operand R11 MOV + ! Restore R14. + R14 SP 4 <-> LDR ; diff --git a/unmaintained/arm/architecture/authors.txt b/unmaintained/arm/architecture/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/architecture/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/arm.factor b/unmaintained/arm/arm.factor new file mode 100755 index 0000000000..2bad556f83 --- /dev/null +++ b/unmaintained/arm/arm.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math namespaces +cpu.architecture cpu.arm.architecture cpu.arm.assembler +cpu.arm.intrinsics generator generator.registers continuations +compiler io vocabs.loader sequences system ; + +! EABI passes floats in integer registers. +[ alien-float ] +[ >r >r >float r> r> set-alien-float ] +4 +"box_float" +"to_float" +"float" define-primitive-type + +[ >float ] "float" c-type set-c-type-prep + +[ alien-double ] +[ >r >r >float r> r> set-alien-double ] +8 +"box_double" +"to_double" +"double" define-primitive-type + +[ >float ] "double" c-type set-c-type-prep + +T{ arm-backend } compiler-backend set-global + +! We don't auto-detect since that would require us to support +! illegal instruction traps. This works on Linux but not on +! Windows CE. + +"arm-variant" get [ + "ARM variant: " write "arm-variant" get print +] [ + "==========" print + "You should specify the -arm-variant= switch." print + " can be one of arm3, arm4, arm4t, or arm5." print + "Assuming arm3." print + "==========" print + "arm3" "arm-variant" set-global +] if + +"arm-variant" get { "arm4" "arm4t" "arm5" } member? [ + "cpu.arm.4" require +] when + +"arm-variant" get { "arm4t" "arm5" } member? [ + t have-BX? set-global +] when + +"arm-variant" get "arm5" = [ + t have-BLX? set-global +] when + +7 cells profiler-prologues set-global diff --git a/unmaintained/arm/assembler/assembler-tests.factor b/unmaintained/arm/assembler/assembler-tests.factor new file mode 100644 index 0000000000..a30ab9f797 --- /dev/null +++ b/unmaintained/arm/assembler/assembler-tests.factor @@ -0,0 +1,45 @@ +IN: cpu.arm.assembler.tests +USING: assembler-arm math test namespaces sequences kernel +quotations ; + +: test-opcode [ { } make first ] curry unit-test ; + +[ HEX: ea000000 ] [ 0 B ] test-opcode +[ HEX: eb000000 ] [ 0 BL ] test-opcode +! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode + +[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode +[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode +[ HEX: e087e3ac ] [ LR R7 IP 7 ADD ] test-opcode +[ HEX: e08c0109 ] [ R0 IP R9 2 ADD ] test-opcode +[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode +[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode + +[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode +[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode +[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode +[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode +[ HEX: e1e01c80 ] [ R1 R0 25 MVN ] test-opcode +[ HEX: e1e00ca1 ] [ R0 R1 25 MVN ] test-opcode +[ HEX: 11a021ac ] [ R2 IP 3 NE MOV ] test-opcode + +[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode + +[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode + +[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode +[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode +[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode + +[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode +[ HEX: e7910102 ] [ R0 R1 R2 2 <+> LDR ] test-opcode + +[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode +[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode +[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode +[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode +[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode +[ HEX: e1f310fc ] [ R1 R3 12 LDRSH ] test-opcode +[ HEX: e1b310d4 ] [ R1 R3 R4 LDRSB ] test-opcode +[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode +[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode diff --git a/unmaintained/arm/assembler/assembler.factor b/unmaintained/arm/assembler/assembler.factor new file mode 100755 index 0000000000..5a69f93d85 --- /dev/null +++ b/unmaintained/arm/assembler/assembler.factor @@ -0,0 +1,330 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generator generator.fixup kernel sequences words +namespaces math math.bitfields ; +IN: cpu.arm.assembler + +: define-registers ( seq -- ) + dup length [ "register" set-word-prop ] 2each ; + +SYMBOL: R0 +SYMBOL: R1 +SYMBOL: R2 +SYMBOL: R3 +SYMBOL: R4 +SYMBOL: R5 +SYMBOL: R6 +SYMBOL: R7 +SYMBOL: R8 +SYMBOL: R9 +SYMBOL: R10 +SYMBOL: R11 +SYMBOL: R12 +SYMBOL: R13 +SYMBOL: R14 +SYMBOL: R15 + +{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 } +define-registers + +PREDICATE: register < word register >boolean ; + +GENERIC: register ( register -- n ) +M: word register "register" word-prop ; +M: f register drop 0 ; + +: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline +: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline + +! Condition codes +SYMBOL: cond-code + +: >CC ( n -- ) + cond-code set ; + +: CC> ( -- n ) + #! Default value is BIN: 1110 AL (= always) + cond-code [ f ] change BIN: 1110 or ; + +: EQ BIN: 0000 >CC ; +: NE BIN: 0001 >CC ; +: CS BIN: 0010 >CC ; +: CC BIN: 0011 >CC ; +: LO BIN: 0100 >CC ; +: PL BIN: 0101 >CC ; +: VS BIN: 0110 >CC ; +: VC BIN: 0111 >CC ; +: HI BIN: 1000 >CC ; +: LS BIN: 1001 >CC ; +: GE BIN: 1010 >CC ; +: LT BIN: 1011 >CC ; +: GT BIN: 1100 >CC ; +: LE BIN: 1101 >CC ; +: AL BIN: 1110 >CC ; +: NV BIN: 1111 >CC ; + +: (insn) ( n -- ) CC> 28 shift bitor , ; + +: insn ( bitspec -- ) bitfield (insn) ; inline + +! Branching instructions +GENERIC# (B) 1 ( signed-imm-24 l -- ) + +M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ; +M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ; +M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ; + +: B 0 (B) ; : BL 1 (B) ; + +! Data processing instructions +SYMBOL: updates-cond-code + +: S ( -- ) updates-cond-code on ; + +: S> ( -- ? ) updates-cond-code [ f ] change ; + +: sinsn ( bitspec -- ) + bitfield S> [ 20 2^ bitor ] when (insn) ; inline + +GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n ) + +M: integer shift-imm/reg ( shift-imm Rm shift -- n ) + { { 0 4 } 5 { register 0 } 7 } bitfield ; + +M: register shift-imm/reg ( Rs Rm shift -- n ) + { + { 1 4 } + { 0 7 } + 5 + { register 8 } + { register 0 } + } bitfield ; + +GENERIC: shifter-op ( shifter-op -- n ) + +TUPLE: IMM immed rotate ; +C: IMM + +M: IMM shifter-op + dup IMM-immed swap IMM-rotate + { { 1 25 } 8 0 } bitfield ; + +TUPLE: shifter Rm by shift ; +C: shifter + +M: shifter shifter-op + dup shifter-by over shifter-Rm rot shifter-shift + shift-imm/reg ; + +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 ; +: ( Rm -- shifter-op ) 0 ; + +M: register shifter-op 0 shifter-op ; + +M: integer shifter-op 0 shifter-op ; + +: addr1 ( Rd Rn shifter-op opcode -- ) + { + 21 ! opcode + { shifter-op 0 } + { register 16 } ! Rn + { register 12 } ! Rd + } sinsn ; + +: AND BIN: 0000 addr1 ; +: EOR BIN: 0001 addr1 ; +: SUB BIN: 0010 addr1 ; +: RSB BIN: 0011 addr1 ; +: ADD BIN: 0100 addr1 ; +: ADC BIN: 0101 addr1 ; +: SBC BIN: 0110 addr1 ; +: RSC BIN: 0111 addr1 ; +: ORR BIN: 1100 addr1 ; +: BIC BIN: 1110 addr1 ; + +: MOV f swap BIN: 1101 addr1 ; +: MVN f swap BIN: 1111 addr1 ; + +! These always update the condition code flags +: (CMP) >r f -rot r> S addr1 ; + +: TST BIN: 1000 (CMP) ; +: TEQ BIN: 1001 (CMP) ; +: CMP BIN: 1010 (CMP) ; +: CMN BIN: 1011 (CMP) ; + +! Multiply instructions +: (MLA) ( Rd Rm Rs Rn a -- ) + { + 21 + { register 12 } + { register 8 } + { register 0 } + { register 16 } + { 1 7 } + { 1 4 } + } sinsn ; + +: MUL ( Rd Rm Rs -- ) f 0 (MLA) ; +: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ; + +: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- ) + { + { 1 23 } + 22 + 21 + { register 8 } + { register 0 } + { register 16 } + { register 12 } + { 1 7 } + { 1 4 } + } sinsn ; + +: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ; +: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ; + +! Miscellaneous arithmetic instructions +: CLZ ( Rd Rm -- ) + { + { 1 24 } + { 1 22 } + { 1 21 } + { BIN: 111 16 } + { BIN: 1111 8 } + { 1 4 } + { register 0 } + { register 12 } + } sinsn ; + +! Status register acess instructions + +! Load and store instructions +GENERIC: addressing-mode-2 ( addressing-mode -- n ) + +TUPLE: addressing p u w ; +: ( delegate p u w -- addressing ) + { + set-delegate + set-addressing-p + set-addressing-u + set-addressing-w + } addressing construct ; + +M: addressing addressing-mode-2 + { + addressing-p addressing-u addressing-w delegate + } get-slots addressing-mode-2 + { 0 21 23 24 } bitfield ; + +M: integer addressing-mode-2 ; + +M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ; + +! Offset +: <+> 1 1 0 ; +: <-> 1 0 0 ; + +! Pre-indexed +: 1 1 1 ; +: 1 0 1 ; + +! Post-indexed +: <+!> 0 1 0 ; +: <-!> 0 0 0 ; + +: addr2 ( Rd Rn addressing-mode b l -- ) + { + { 1 26 } + 20 + 22 + { addressing-mode-2 0 } + { register 16 } + { register 12 } + } insn ; + +: LDR 0 1 addr2 ; +: LDRB 1 1 addr2 ; +: STR 0 0 addr2 ; +: STRB 1 0 addr2 ; + +! We might have to simulate these instructions since older ARM +! chips don't have them. +SYMBOL: have-BX? +SYMBOL: have-BLX? + +GENERIC# (BX) 1 ( Rm l -- ) + +M: register (BX) ( Rm l -- ) + { + { 1 24 } + { 1 21 } + { BIN: 1111 16 } + { BIN: 1111 12 } + { BIN: 1111 8 } + 5 + { 1 4 } + { register 0 } + } insn ; + +M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ; + +M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ; + +: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ; + +: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ; + +! More load and store instructions +GENERIC: addressing-mode-3 ( addressing-mode -- n ) + +: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ; + +M: addressing addressing-mode-3 + [ addressing-p ] keep + [ addressing-u ] keep + [ addressing-w ] keep + delegate addressing-mode-3 + { 0 21 23 24 } bitfield ; + +M: integer addressing-mode-3 + b>n/n { + ! { 1 24 } + { 1 22 } + { 1 7 } + { 1 4 } + 0 + 8 + } bitfield ; + +M: object addressing-mode-3 + shifter-op { + ! { 1 24 } + { 1 7 } + { 1 4 } + 0 + } bitfield ; + +: addr3 ( Rn Rd addressing-mode h l s -- ) + { + 6 + 20 + 5 + { addressing-mode-3 0 } + { register 16 } + { register 12 } + } insn ; + +: LDRH 1 1 0 addr3 ; +: LDRSB 0 1 1 addr3 ; +: LDRSH 1 1 1 addr3 ; +: STRH 1 0 0 addr3 ; + +! Load and store multiple instructions + +! Semaphore instructions + +! Exception-generating instructions diff --git a/unmaintained/arm/assembler/authors.txt b/unmaintained/arm/assembler/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/assembler/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/authors.txt b/unmaintained/arm/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/bootstrap.factor b/unmaintained/arm/bootstrap.factor new file mode 100755 index 0000000000..793a488063 --- /dev/null +++ b/unmaintained/arm/bootstrap.factor @@ -0,0 +1,119 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private kernel namespaces system +cpu.arm.assembler math layouts words compiler.units ; +IN: bootstrap.arm + +! We generate ARM3 code +f have-BX? set + +4 \ cell set +big-endian off + +4 jit-code-format set + +: ds-reg R5 ; + +: word-reg R0 ; +: quot-reg R0 ; +: scan-reg R2 ; +: temp-reg R3 ; +: xt-reg R12 ; + +: stack-frame 16 bootstrap-cells ; + +: next-save stack-frame 2 bootstrap-cells - ; +: xt-save stack-frame 3 bootstrap-cells - ; +: array-save stack-frame 4 bootstrap-cells - ; +: scan-save stack-frame 5 bootstrap-cells - ; + +[ + temp-reg quot-reg quot-array@ <+> LDR ! load array + scan-reg temp-reg scan@ ADD ! initialize scan pointer +] { } make jit-setup set + +[ + LR SP 4 <-> STR ! save return address + SP SP stack-frame SUB + xt-reg SP xt-save <+> STR ! save XT + xt-reg stack-frame MOV + xt-reg SP next-save <+> STR ! save frame size + temp-reg SP array-save <+> STR ! save array +] { } make jit-prolog set + +[ + temp-reg scan-reg 4 LDR ! load literal and advance + temp-reg ds-reg 4 STR ! push literal +] { } make jit-push-literal set + +[ + temp-reg scan-reg 4 LDR ! load wrapper and advance + temp-reg dup wrapper@ <+> LDR ! load wrapped object + temp-reg ds-reg 4 STR ! push wrapped object +] { } make jit-push-wrapper set + +[ + R1 SP 4 SUB ! pass stack pointer to primitive +] { } make jit-word-primitive-jump set + +[ + R1 SP 4 SUB ! pass stack pointer to primitive +] { } make jit-word-primitive-call set + +: load-word-xt ( -- ) + word-reg scan-reg 4 LDR ! load word and advance + xt-reg word-reg word-xt@ <+> LDR ; + +: jit-call + scan-reg SP scan-save <+> STR ! save scan pointer + LR PC MOV ! save return address + xt-reg BX ! call + scan-reg SP scan-save <+> LDR ! restore scan pointer + ; + +: jit-jump + xt-reg BX ; + +[ load-word-xt jit-call ] { } make jit-word-call set + +[ load-word-xt jit-jump ] { } make jit-word-jump set + +: load-quot-xt + xt-reg quot-reg quot-xt@ <+> LDR ; + +: load-branch + temp-reg ds-reg 4 <-!> LDR ! pop boolean + temp-reg \ f tag-number CMP ! compare it with f + quot-reg scan-reg MOV ! point quot-reg at false branch + quot-reg dup 4 EQ ADD ! point quot-reg at true branch + quot-reg dup 4 <+> LDR ! load the branch + scan-reg dup 12 ADD ! advance scan pointer + load-quot-xt + ; + +[ + load-branch jit-jump +] { } make jit-if-jump set + +[ + load-branch jit-call +] { } make jit-if-call set + +[ + temp-reg ds-reg 4 <-!> LDR ! pop index + temp-reg dup 1 MOV ! turn it into an array offset + scan-reg dup 4 <+> LDR ! load array + temp-reg dup scan-reg ADD ! compute quotation location + quot-reg temp-reg array-start <+> LDR ! load quotation + load-quot-xt + jit-jump +] { } make jit-dispatch set + +[ + SP SP stack-frame ADD ! pop stack frame + LR SP 4 <-> LDR ! load return address +] { } make jit-epilog set + +[ LR BX ] { } make jit-return set + +[ "bootstrap.arm" forget-vocab ] with-compilation-unit diff --git a/unmaintained/arm/intrinsics/authors.txt b/unmaintained/arm/intrinsics/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/arm/intrinsics/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unmaintained/arm/intrinsics/intrinsics.factor b/unmaintained/arm/intrinsics/intrinsics.factor new file mode 100755 index 0000000000..e9902888eb --- /dev/null +++ b/unmaintained/arm/intrinsics/intrinsics.factor @@ -0,0 +1,462 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien arrays cpu.architecture cpu.arm.assembler +cpu.arm.architecture cpu.arm.allot kernel kernel.private math +math.private namespaces sequences words +quotations byte-arrays hashtables.private hashtables generator +generator.registers generator.fixup sequences.private sbufs +sbufs.private vectors vectors.private system +classes.tuple.private layouts strings.private slots.private ; +IN: cpu.arm.intrinsics + +: %slot-literal-known-tag + "val" operand + "obj" operand + "n" get cells + "obj" get operand-tag - <+/-> ; + +: %slot-literal-any-tag + "scratch" operand "obj" operand %untag + "val" operand "scratch" operand "n" get cells <+> ; + +: %slot-any + "scratch" operand "obj" operand %untag + "n" operand dup 1 MOV + "val" operand "scratch" operand "n" operand <+> ; + +\ slot { + ! Slot number is literal and the tag is known + { + [ %slot-literal-known-tag LDR ] H{ + { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } } + { +scratch+ { { f "val" } } } + { +output+ { "val" } } + } + } + ! Slot number is literal + { + [ %slot-literal-any-tag LDR ] H{ + { +input+ { { f "obj" } { [ small-slot? ] "n" } } } + { +scratch+ { { f "scratch" } { f "val" } } } + { +output+ { "val" } } + } + } + ! Slot number in a register + { + [ %slot-any LDR ] H{ + { +input+ { { f "obj" } { f "n" } } } + { +scratch+ { { f "val" } { f "scratch" } } } + { +output+ { "val" } } + { +clobber+ { "n" } } + } + } +} define-intrinsics + +: %write-barrier ( -- ) + "val" get operand-immediate? "obj" get fresh-object? or [ + "cards_offset" f R12 %alien-global + "scratch" operand R12 "obj" operand card-bits ADD + "val" operand "scratch" operand 0 <+> LDRB + "val" operand dup card-mark ORR + "val" operand "scratch" operand 0 <+> STRB + ] unless ; + +\ set-slot { + ! Slot number is literal and tag is known + { + [ %slot-literal-known-tag STR %write-barrier ] H{ + { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } } + { +scratch+ { { f "scratch" } } } + { +clobber+ { "val" } } + } + } + ! Slot number is literal + { + [ %slot-literal-any-tag STR %write-barrier ] H{ + { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } + { +scratch+ { { f "scratch" } } } + { +clobber+ { "val" } } + } + } + ! Slot number is in a register + { + [ %slot-any STR %write-barrier ] H{ + { +input+ { { f "val" } { f "obj" } { f "n" } } } + { +scratch+ { { f "scratch" } } } + { +clobber+ { "val" "n" } } + } + } +} define-intrinsics + +: fixnum-op ( op -- quot ) + [ "out" operand "x" operand "y" operand ] swap add ; + +: fixnum-register-op ( op -- pair ) + fixnum-op H{ + { +input+ { { f "x" } { f "y" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } + } 2array ; + +: fixnum-value-op ( op -- pair ) + fixnum-op H{ + { +input+ { { f "x" } { [ small-tagged? ] "y" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } + } 2array ; + +: define-fixnum-op ( word op -- ) + [ fixnum-value-op ] keep fixnum-register-op 2array + define-intrinsics ; + +{ + { fixnum+fast ADD } + { fixnum-fast SUB } + { fixnum-bitand AND } + { fixnum-bitor ORR } + { fixnum-bitxor EOR } +} [ + first2 define-fixnum-op +] each + +\ fixnum-bitnot [ + "x" operand dup MVN + "x" operand dup %untag +] H{ + { +input+ { { f "x" } } } + { +output+ { "x" } } +} define-intrinsic + +\ fixnum*fast [ + "out" operand "y" operand %untag-fixnum + "out" operand "x" operand "out" operand MUL +] H{ + { +input+ { { f "x" } { f "y" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ fixnum-shift [ + "out" operand "x" operand "y" get neg MOV + ! Mask off low bits + "out" operand dup %untag +] H{ + { +input+ { { f "x" } { [ -31 0 between? ] "y" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +: %untag-fixnums ( seq -- ) + [ dup %untag-fixnum ] unique-operands ; + +: overflow-check ( insn -- ) + [ + "end" define-label + [ "out" operand "x" operand "y" operand roll S execute ] keep + "end" get VC B + { "x" "y" } %untag-fixnums + "x" operand "x" operand "y" operand roll execute + "out" get "x" get %allot-bignum-signed-1 + "end" resolve-label + ] with-scope ; inline + +: overflow-template ( word insn -- ) + [ overflow-check ] curry H{ + { +input+ { { f "x" } { f "y" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } + { +clobber+ { "x" "y" } } + } define-intrinsic ; + +\ fixnum+ \ ADD overflow-template +\ fixnum- \ SUB overflow-template + +\ fixnum>bignum [ + "x" operand dup %untag-fixnum + "out" get "x" get %allot-bignum-signed-1 +] H{ + { +input+ { { f "x" } } } + { +scratch+ { { f "out" } } } + { +clobber+ { "x" } } + { +output+ { "out" } } +} define-intrinsic + +\ bignum>fixnum [ + "end" define-label + "x" operand dup %untag + "y" operand "x" operand cell <+> LDR + ! if the length is 1, its just the sign and nothing else, + ! so output 0 + "y" operand 1 v>operand CMP + "y" operand 0 EQ MOV + "end" get EQ B + ! load the value + "y" operand "x" operand 3 cells <+> LDR + ! load the sign + "x" operand "x" operand 2 cells <+> LDR + ! is the sign negative? + "x" operand 0 CMP + ! Negate the value + "y" operand "y" operand 0 NE RSB + "y" operand dup %tag-fixnum + "end" resolve-label +] H{ + { +input+ { { f "x" } } } + { +scratch+ { { f "y" } } } + { +clobber+ { "x" } } + { +output+ { "y" } } +} define-intrinsic + +: fixnum-jump ( op -- quo ) + [ "x" operand "y" operand CMP ] swap + 1quotation [ B ] 3append ; + +: fixnum-register-jump ( op -- pair ) + fixnum-jump { { f "x" } { f "y" } } 2array ; + +: fixnum-value-jump ( op -- pair ) + fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ; + +: define-fixnum-jump ( word op -- ) + [ fixnum-value-jump ] keep fixnum-register-jump + 2array define-if-intrinsics ; + +{ + { fixnum< LT } + { fixnum<= LE } + { fixnum> GT } + { fixnum>= GE } + { eq? EQ } +} [ + first2 define-fixnum-jump +] each + +\ tag [ + "out" operand "in" operand tag-mask get AND + "out" operand dup %tag-fixnum +] H{ + { +input+ { { f "in" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ type [ + ! Get the tag + "out" operand "obj" operand tag-mask get AND + ! Compare with object tag number (3). + "out" operand object tag-number CMP + ! Tag the tag if it is not equal to 3 + "out" operand dup NE %tag-fixnum + ! Load the object header if tag is equal to 3 + "out" operand "obj" operand object tag-number <-> EQ LDR +] H{ + { +input+ { { f "obj" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ class-hash [ + "end" define-label + ! Get the tag + "out" operand "obj" operand tag-mask get AND + ! Compare with tuple tag number (2). + "out" operand tuple tag-number CMP + "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR + "out" operand dup class-hash-offset <+/-> EQ LDR + "end" get EQ B + ! Compare with object tag number (3). + "out" operand object tag-number CMP + "out" operand "obj" operand object tag-number <-> EQ LDR + ! Tag the tag + "out" operand dup NE %tag-fixnum + "end" resolve-label +] H{ + { +input+ { { f "obj" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +: userenv ( reg -- ) + #! Load the userenv pointer in a register. + "userenv" f rot compile-dlsym ; + +\ getenv [ + "n" operand dup 1 MOV + "x" operand userenv + "x" operand "x" operand "n" operand <+> LDR +] H{ + { +input+ { { f "n" } } } + { +scratch+ { { f "x" } } } + { +output+ { "x" } } + { +clobber+ { "n" } } +} define-intrinsic + +\ setenv [ + "n" operand dup 1 MOV + "x" operand userenv + "val" operand "x" operand "n" operand <+> STR +] H{ + { +input+ { { f "val" } { f "n" } } } + { +scratch+ { { f "x" } } } + { +clobber+ { "n" } } +} define-intrinsic + +: %set-slot R11 swap cells <+> STR ; + +: %store-length + R12 "n" operand MOV + R12 1 %set-slot ; + +: %fill-array swap 2 + %set-slot ; + +\ [ + tuple "n" get 2 + cells %allot + %store-length + ! Store class + "class" operand 2 %set-slot + ! Zero out the rest of the tuple + "initial" operand f v>operand MOV + "n" get 1- [ 1+ "initial" operand %fill-array ] each + "out" get tuple %store-tagged +] H{ + { +input+ { { f "class" } { [ inline-array? ] "n" } } } + { +scratch+ { { f "out" } { f "initial" } } } + { +output+ { "out" } } +} define-intrinsic + +\ [ + array "n" get 2 + cells %allot + %store-length + ! Store initial element + "n" get [ "initial" operand %fill-array ] each + "out" get object %store-tagged +] H{ + { +input+ { { [ inline-array? ] "n" } { f "initial" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ [ + byte-array "n" get 2 cells + %allot + %store-length + ! Store initial element + R12 0 MOV + "n" get cell align cell /i [ R12 %fill-array ] each + "out" get object %store-tagged +] H{ + { +input+ { { [ inline-array? ] "n" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ [ + ratio 3 cells %allot + "numerator" operand 1 %set-slot + "denominator" operand 2 %set-slot + "out" get ratio %store-tagged +] H{ + { +input+ { { f "numerator" } { f "denominator" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ [ + complex 3 cells %allot + "real" operand 1 %set-slot + "imaginary" operand 2 %set-slot + ! Store tagged ptr in reg + "out" get complex %store-tagged +] H{ + { +input+ { { f "real" } { f "imaginary" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ [ + wrapper 2 cells %allot + "obj" operand 1 %set-slot + ! Store tagged ptr in reg + "out" get object %store-tagged +] H{ + { +input+ { { f "obj" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +! Alien intrinsics +: %alien-accessor ( quot -- ) + "offset" operand dup %untag-fixnum + "offset" operand dup "alien" operand ADD + "value" operand "offset" operand 0 <+> roll call ; inline + +: alien-integer-get-template + H{ + { +input+ { + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +scratch+ { { f "value" } } } + { +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 } + } } + { +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 [ LDRB ] +\ set-alien-unsigned-1 [ STRB ] +define-alien-integer-intrinsics + +: alien-cell-template + H{ + { +input+ { + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +scratch+ { { unboxed-alien "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } + } ; + +\ alien-cell +[ [ LDR ] %alien-accessor ] +alien-cell-template define-intrinsic + +: set-alien-cell-template + H{ + { +input+ { + { unboxed-c-ptr "value" pinned-c-ptr } + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +clobber+ { "offset" } } + } ; + +\ set-alien-cell +[ [ STR ] %alien-accessor ] +set-alien-cell-template define-intrinsic diff --git a/unmaintained/arm/summary.txt b/unmaintained/arm/summary.txt new file mode 100644 index 0000000000..f3e46d9f43 --- /dev/null +++ b/unmaintained/arm/summary.txt @@ -0,0 +1 @@ +ARM3 compiler backend diff --git a/unmaintained/arm/tags.txt b/unmaintained/arm/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/unmaintained/arm/tags.txt @@ -0,0 +1 @@ +compiler