steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://factorcode.org/git/factor

db4
Doug Coleman 2008-01-15 18:24:14 -10:00
parent ba68a3732d 123b3da7bf
commit 06d65e9eb5
19 changed files with 215 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/compiler/test/simple.factor
View File

@ -63,3 +63,9 @@ IN: temporary
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
! Regression
: empty ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

15
core/cpu/architecture/architecture.factor
View File

@ -51,19 +51,28 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call C primitive
HOOK: %call-primitive compiler-backend ( label -- )
! Call another label
HOOK: %call-label compiler-backend ( label -- )
! Far jump to C primitive
HOOK: %jump-primitive compiler-backend ( label -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
! We pass the offset of the jump table start in the world table
HOOK: %call-dispatch compiler-backend ( word-table# -- )
HOOK: %call-dispatch compiler-backend ( -- label )
HOOK: %jump-dispatch compiler-backend ( word-table# -- )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
HOOK: %end-dispatch compiler-backend ( label -- )
! Return to caller
HOOK: %return compiler-backend ( -- )

55
core/cpu/ppc/architecture/architecture.factor
View File

@ -97,6 +97,22 @@ M: ppc-backend %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
: %prepare-primitive ( word -- )
#! Save stack pointer to stack_chain->callstack_top, load XT
4 1 MR
0 11 LOAD32
rc-absolute-ppc-2/2 rel-primitive ;
: (%call) 11 MTLR BLRL ;
M: ppc-backend %call-primitive ( word -- )
%prepare-primitive (%call) ;
: (%jump) 11 MTCTR BCTR ;
M: ppc-backend %jump-primitive ( word -- )
%prepare-primitive (%jump) ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@ -107,26 +123,29 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
: (%call) 11 MTLR BLRL ;
: dispatch-template ( word-table# quot -- )
[
>r
"offset" operand "n" operand 1 SRAWI
0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
11 dup "offset" operand LWZX
11 dup word-xt-offset LWZ
r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ; inline
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup rot cells LWZ ;
M: ppc-backend %call-dispatch ( word-table# -- )
[ (%call) ] dispatch-template ;
[ 7 (%dispatch) (%call) <label> dup B ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc-backend %end-dispatch ( label -- )
resolve-label ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
@ -271,7 +290,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
: %untag-fixnum ( src dest -- ) tag-bits get SRAWI ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way

38
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
: %slot-any
"obj" operand "scratch" operand %untag
"n" operand dup 1 SRAWI
"scratch" operand "val" operand "n" operand ;
"offset" operand "n" operand 1 SRAWI
"scratch" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
@ -47,9 +47,8 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "val" } { f "scratch" } } }
{ +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
{ +output+ { "val" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics
@ -88,33 +87,34 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" "n" } }
{ +scratch+ { { f "scratch" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
} define-intrinsics
: (%char-slot)
"offset" operand "n" operand 2 SRAWI
"offset" operand dup "obj" operand ADD ;
\ char-slot [
"out" operand "obj" operand MR
"n" operand dup 2 SRAWI
"n" operand "obj" operand "n" operand ADD
"out" operand "n" operand string-offset LHZ
(%char-slot)
"out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
{ +clobber+ { "n" } }
} define-intrinsic
\ set-char-slot [
(%char-slot)
"val" operand dup %untag-fixnum
"slot" operand dup 2 SRAWI
"slot" operand dup "obj" operand ADD
"val" operand "slot" operand string-offset STH
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" } }
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair )
@ -185,10 +185,10 @@ IN: cpu.ppc.intrinsics
{
[
{ "positive" "end" } [ define-label ] each
"y" operand "out" operand swap %untag-fixnum
"out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"y" operand dup NEG
"out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label

47
core/cpu/x86/architecture/architecture.factor
View File

@ -70,6 +70,14 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %call-primitive ( word -- )
stack-save-reg stack-reg cell neg [+] LEA
address-operand CALL ;
M: x86-backend %jump-primitive ( word -- )
stack-save-reg stack-reg MOV
address-operand JMP ;
M: x86-backend %call-label ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
@ -77,30 +85,31 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: (%dispatch) ( word-table# -- )
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add to jump table base. We use a temporary register
: (%dispatch) ( -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
"scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
"n" operand "n" operand "scratch" operand [+] MOV
"n" operand dup word-xt-offset [+] MOV ;
: dispatch-template ( word-table# quot -- )
[
>r (%dispatch) "n" operand r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "n" } }
} with-template ; inline
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand bootstrap-cell 8 = 14 9 ? [+] ;
M: x86-backend %call-dispatch ( word-table# -- )
[ CALL ] dispatch-template ;
[ (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: x86-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later JMP ] dispatch-template ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later (%dispatch) JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: x86-backend %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ;

98
core/cpu/x86/assembler/assembler.factor
View File

@ -11,78 +11,42 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
: define-register ( symbol num size -- )
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
! x86 registers
SYMBOL: AL \ AL 0 8 define-register
SYMBOL: CL \ CL 1 8 define-register
SYMBOL: DL \ DL 2 8 define-register
SYMBOL: BL \ BL 3 8 define-register
SYMBOL: AX \ AX 0 16 define-register
SYMBOL: CX \ CX 1 16 define-register
SYMBOL: DX \ DX 2 16 define-register
SYMBOL: BX \ BX 3 16 define-register
SYMBOL: SP \ SP 4 16 define-register
SYMBOL: BP \ BP 5 16 define-register
SYMBOL: SI \ SI 6 16 define-register
SYMBOL: DI \ DI 7 16 define-register
SYMBOL: EAX \ EAX 0 32 define-register
SYMBOL: ECX \ ECX 1 32 define-register
SYMBOL: EDX \ EDX 2 32 define-register
SYMBOL: EBX \ EBX 3 32 define-register
SYMBOL: ESP \ ESP 4 32 define-register
SYMBOL: EBP \ EBP 5 32 define-register
SYMBOL: ESI \ ESI 6 32 define-register
SYMBOL: EDI \ EDI 7 32 define-register
SYMBOL: XMM0 \ XMM0 0 128 define-register
SYMBOL: XMM1 \ XMM1 1 128 define-register
SYMBOL: XMM2 \ XMM2 2 128 define-register
SYMBOL: XMM3 \ XMM3 3 128 define-register
SYMBOL: XMM4 \ XMM4 4 128 define-register
SYMBOL: XMM5 \ XMM5 5 128 define-register
SYMBOL: XMM6 \ XMM6 6 128 define-register
SYMBOL: XMM7 \ XMM7 7 128 define-register
! AMD64 registers
SYMBOL: RAX \ RAX 0 64 define-register
SYMBOL: RCX \ RCX 1 64 define-register
SYMBOL: RDX \ RDX 2 64 define-register
SYMBOL: RBX \ RBX 3 64 define-register
SYMBOL: RSP \ RSP 4 64 define-register
SYMBOL: RBP \ RBP 5 64 define-register
SYMBOL: RSI \ RSI 6 64 define-register
SYMBOL: RDI \ RDI 7 64 define-register
SYMBOL: R8 \ R8 8 64 define-register
SYMBOL: R9 \ R9 9 64 define-register
SYMBOL: R10 \ R10 10 64 define-register
SYMBOL: R11 \ R11 11 64 define-register
SYMBOL: R12 \ R12 12 64 define-register
SYMBOL: R13 \ R13 13 64 define-register
SYMBOL: R14 \ R14 14 64 define-register
SYMBOL: R15 \ R15 15 64 define-register
SYMBOL: XMM8 \ XMM8 8 128 define-register
SYMBOL: XMM9 \ XMM9 9 128 define-register
SYMBOL: XMM10 \ XMM10 10 128 define-register
SYMBOL: XMM11 \ XMM11 11 128 define-register
SYMBOL: XMM12 \ XMM12 12 128 define-register
SYMBOL: XMM13 \ XMM13 13 128 define-register
SYMBOL: XMM14 \ XMM14 14 128 define-register
SYMBOL: XMM15 \ XMM15 15 128 define-register
<PRIVATE
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
! Register operands -- eg, ECX
<<
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS:
scan-word ";" parse-tokens swap define-registers ; parsing
>>
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )

7
core/generator/fixup/fixup.factor
View File

@ -69,6 +69,7 @@ SYMBOL: label-table
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
TUPLE: label-fixup label class ;
@ -129,12 +130,18 @@ SYMBOL: word-table
: rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
V{ } clone relocation-table set
V{ } clone label-table set ;

47
core/generator/generator.factor
View File

@ -104,14 +104,21 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
: %call ( word -- ) %call-label ;
: %call ( word -- )
dup primitive? [ %call-primitive ] [ %call-label ] if ;
: %jump ( word -- )
dup compiling-label get eq? [
drop current-label-start get %jump-label
] [
%epilogue-later %jump-label
] if ;
{
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label
] }
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
%epilogue-later %jump-label
] }
} cond ;
: generate-call ( label -- next )
dup maybe-compile
@ -162,22 +169,22 @@ M: #if generate-node
] generate-1
] keep ;
: dispatch-branches ( node -- syms )
node-children
[ compiling-word get dispatch-branch ] map
word-table get push-all ;
: %dispatch ( word-table# -- )
tail-call? [
%jump-dispatch
] [
0 frame-required
%call-dispatch
] if ;
: dispatch-branches ( node -- )
node-children [
compiling-word get dispatch-branch %dispatch-label
] each ;
M: #dispatch generate-node
word-table get length %dispatch
dispatch-branches init-templates iterate-next ;
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
%jump-dispatch dispatch-branches
] [
0 frame-required
%call-dispatch >r dispatch-branches r> %end-dispatch
] if
init-templates iterate-next ;
! #call
: define-intrinsics ( word intrinsics -- )

21
core/inference/class/class-tests.factor
View File

@ -3,7 +3,8 @@ USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units ;
slots.private combinators definitions compiler.units
system ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -251,12 +252,14 @@ M: fixnum annotate-entry-test-1 drop ;
\ fixnum-shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] when

10
core/kernel/kernel-tests.factor
View File

@ -108,3 +108,13 @@ IN: temporary
[ drop foo ] unit-test-fails
[ ] [ :c ] unit-test
! Regression
: (loop) ( a b c d -- )
>r pick r> swap >r pick r> swap
< [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- )
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] unit-test-fails

6
core/optimizer/known-words/known-words.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
@ -149,6 +149,10 @@ float-arrays combinators.private combinators ;
\ >array { { string vector } } "specializer" set-word-prop
\ >vector { { array vector } } "specializer" set-word-prop
\ >sbuf { string } "specializer" set-word-prop
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop

9
core/prettyprint/prettyprint-tests.factor
View File

@ -290,6 +290,14 @@ unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
! Regression
[ t ] [
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval
"generic-decl-test" "temporary" lookup
[ see ] string-out =
] unit-test
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
@ -313,4 +321,3 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test

1
core/prettyprint/prettyprint.factor
View File

@ -207,6 +207,7 @@ M: word declarations.
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;

2
core/sequences/sequences.factor
View File

@ -199,7 +199,7 @@ TUPLE: slice-error reason ;
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
slice construct-boa ;
slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;

5
core/syntax/syntax.factor
View File

@ -170,5 +170,8 @@ IN: bootstrap.syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [ \ >> parse-until >quotation call ] define-syntax
"<<" [
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
] with-compilation-unit

2
core/vectors/vectors.factor
View File

@ -7,7 +7,7 @@ IN: vectors
: <vector> ( n -- vector ) f <array> 0 array>vector ; inline
: >vector ( seq -- vector ) V{ } clone-like ; inline
: >vector ( seq -- vector ) V{ } clone-like ;
M: vector like
drop dup vector? [

4
extra/multi-methods/multi-methods.factor
View File

@ -3,7 +3,7 @@
USING: kernel math sequences vectors classes combinators
arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io ;
debugger io compiler.units ;
IN: multi-methods
TUPLE: method loc def ;
@ -217,5 +217,5 @@ syntax:M: method-spec synopsis*
dup definer.
unclip pprint* pprint* ;
syntax:M: method-spec forget
syntax:M: method-spec forget*
unclip [ delete-at ] with-methods ;

2
vm/code_heap.c
View File

@ -52,6 +52,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT:
return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
return rel->offset + code_start;
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
default:

4
vm/code_heap.h
View File

@ -9,8 +9,8 @@ typedef enum {
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* reserved */
RT_RESERVED,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL
} F_RELTYPE;