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

minor reorganization of low-level code, further work on VOPs

cvs
Slava Pestov 2005-05-06 23:49:07 +00:00
parent 429eb9cdb5
commit ec393e6dee
15 changed files with 187 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
factor/VocabularyLookup.java
View File

@ -82,6 +82,12 @@ public class VocabularyLookup
FactorWord ket = define("syntax","]");
ket.parsing = new Ket(bra,ket);
/* tuples */
FactorWord beginTuple = define("syntax","<<");
beginTuple.parsing = new Bra(beginTuple);
FactorWord endTuple = define("syntax",">>");
endTuple.parsing = new Ket(beginTuple,endTuple);
/* conses */
FactorWord beginCons = define("syntax","[[");
beginCons.parsing = new BeginCons(beginCons);

14
library/bootstrap/image.factor
View File

@ -15,9 +15,9 @@
! run platform/native/boot-stage2.factor.
IN: image
USING: errors generic hashtables kernel lists math namespaces
parser prettyprint sequences sequences stdio streams strings
vectors words ;
USING: errors generic hashtables kernel lists
math namespaces parser prettyprint sequences sequences stdio
streams strings vectors words ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -37,17 +37,9 @@ SYMBOL: boot-quot
: cell "64-bits" get 8 4 ? ;
: char "64-bits" get 4 2 ? ;
: tag-mask BIN: 111 ; inline
: tag-bits 3 ; inline
: untag ( cell tag -- ) tag-mask bitnot bitand ;
: tag ( cell -- tag ) tag-mask bitand ;
: fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: t-type 7 ; inline
: array-type 8 ; inline
: hashtable-type 10 ; inline

92
library/compiler/intrinsics.factor
View File

@ -53,7 +53,6 @@ words ;
out-1
] "linearizer" set-word-prop
\ >r [
drop
in-1
@ -78,9 +77,10 @@ words ;
: self ( word -- )
f swap dup "infer-effect" word-prop (consume/produce) ;
\ slot [
\ slot self
] "infer" set-word-prop
: intrinsic ( word -- )
dup [ literal, \ self , ] make-list "infer" set-word-prop ;
\ slot intrinsic
: slot@ ( seq -- n )
#! Compute slot offset.
@ -102,9 +102,7 @@ words ;
] ifte out-1
] "linearizer" set-word-prop
\ set-slot [
\ set-slot self
] "infer" set-word-prop
\ set-slot intrinsic
\ set-slot [
node-consume-d swap hash
@ -122,37 +120,49 @@ words ;
] ifte
] "linearizer" set-word-prop
! : binary-op-reg ( op -- )
! in-2
! [[ << vreg f 1 >> << vreg f 0 >> ]] cons ,
! 1 %dec-d , out-1 ;
!
!
! : binary-op ( node op -- )
! top-literal? [
! 1 %dec-d ,
! in-1
! literal-value << vreg f 0 >> swons cons ,
! out-1
! ] [
! drop
! binary-op-reg
! ] ifte ;
!
! [
! fixnum+
! fixnum-
! fixnum*
! fixnum-mod
! fixnum-bitand
! fixnum-bitor
! fixnum-bitxor
! fixnum/i
! fixnum<=
! fixnum<
! fixnum>=
! fixnum>
! ] [
! dup [ literal, \ binary-op , ] make-list
! "linearizer" set-word-prop
! ] each
\ type intrinsic
\ type [
drop
in-1
0 %type ,
out-1
] "linearizer" set-word-prop
: binary-op-reg ( op -- )
in-2
<< vreg f 1 >> << vreg f 0 >> rot execute ,
1 %dec-d ,
out-1 ;
: binary-op ( node op -- )
node-consume-d rot hash
dup top-literal? [
1 %dec-d ,
in-1
peek literal-value << vreg f 0 >> rot execute ,
out-1
] [
drop
binary-op-reg
] ifte ;
[
[[ fixnum+ %fixnum+ ]]
[[ fixnum- %fixnum- ]]
[[ fixnum* %fixnum* ]]
[[ fixnum-mod %fixnum-mod ]]
[[ fixnum-bitand %fixnum-bitand ]]
[[ fixnum-bitor %fixnum-bitor ]]
[[ fixnum-bitxor %fixnum-bitxor ]]
[[ fixnum/i %fixnum/i ]]
[[ fixnum<= %fixnum<= ]]
[[ fixnum< %fixnum< ]]
[[ fixnum>= %fixnum>= ]]
[[ fixnum> %fixnum> ]]
] [
uncons over intrinsic
[ literal, \ binary-op , ] make-list
"linearizer" set-word-prop
] each

4
library/compiler/linearizer.factor
View File

@ -78,7 +78,9 @@ errors prettyprint kernel-internals ;
: dispatch-head ( vtable -- end label/code )
#! Output the jump table insn and return a list of
#! label/branch pairs.
%dispatch ,
in-1
1 %dec-d ,
0 %dispatch ,
<label> ( end label ) swap
[ <label> dup %target-label , cons ] map
%end-dispatch , ;

25
library/compiler/vops.factor
View File

@ -28,6 +28,7 @@ GENERIC: generate-node ( vop -- )
: label-vop ( label) >r f f f r> ;
: label/src-vop ( label src) swap >r f f r> ;
: src-vop ( src) f f f ;
: src/dest-vop ( src dest) f f ;
! miscellanea
VOP: %prologue
@ -53,7 +54,7 @@ VOP: %jump-f
! dispatch tables
VOP: %dispatch
: %dispatch empty-vop <%dispatch> ;
: %dispatch <vreg> src-vop <%dispatch> ;
VOP: %target-label
: %target-label label-vop <%target-label> ;
VOP: %target
@ -90,7 +91,7 @@ VOP: %inc-r
! indirect load of a literal through a table
VOP: %indirect
: %indirect ( vreg obj -- ) f -rot f <%indirect> ;
: %indirect ( vreg obj -- ) >r <vreg> r> f -rot f <%indirect> ;
! object slot accessors
VOP: %untag
@ -102,10 +103,28 @@ VOP: %set-slot
: %set-slot ( vreg:value vreg:obj n )
>r >r <vreg> r> <vreg> r> <vreg> f <%set-slot> ;
! In the 'fast' versions, the object's type and slot number is
! in the 'fast' versions, the object's type and slot number is
! known at compile time, so these become a single instruction
VOP: %fast-slot
: %fast-slot ( vreg n ) >r >r f r> <vreg> r> f <%fast-slot> ;
VOP: %fast-set-slot
: %fast-set-slot ( vreg:value vreg:obj n )
>r >r <vreg> r> <vreg> r> f <%fast-set-slot> ;
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> src-vop <%type> ;
! fixnum intrinsics
VOP: %fixnum+ : %fixnum+ src/dest-vop <%fixnum+> ;
VOP: %fixnum- : %fixnum- src/dest-vop <%fixnum-> ;
VOP: %fixnum* : %fixnum* src/dest-vop <%fixnum*> ;
VOP: %fixnum-mod : %fixnum-mod src/dest-vop <%fixnum-mod> ;
VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ;
VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
VOP: %fixnum/i : %fixnum/i src/dest-vop <%fixnum/i> ;
VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ;

33
library/compiler/x86/assembler.factor
View File

@ -241,15 +241,35 @@ M: operand CALL HEX: ff compile-byte BIN: 010 1-operand ;
GENERIC: ADD ( dst src -- )
M: integer ADD HEX: 81 BIN: 000 immediate-8/32 ;
M: operand ADD HEX: 01 2-operand ;
M: operand ADD OCT: 001 2-operand ;
GENERIC: SUB ( dst src -- )
M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ;
M: operand SUB HEX: 29 2-operand ;
GENERIC: OR ( dst src -- )
M: integer OR HEX: 81 BIN: 001 immediate-8/32 ;
M: operand OR OCT: 011 2-operand ;
GENERIC: ADC ( dst src -- )
M: integer ADC HEX: 81 BIN: 010 immediate-8/32 ;
M: operand ADC OCT: 021 2-operand ;
GENERIC: SBB ( dst src -- )
M: integer SBB HEX: 81 BIN: 011 immediate-8/32 ;
M: operand SBB OCT: 031 2-operand ;
GENERIC: AND ( dst src -- )
M: integer AND HEX: 81 BIN: 100 immediate-8/32 ;
M: operand AND HEX: 21 2-operand ;
M: operand AND OCT: 041 2-operand ;
GENERIC: SUB ( dst src -- )
M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ;
M: operand SUB OCT: 051 2-operand ;
GENERIC: XOR ( dst src -- )
M: integer XOR HEX: 81 BIN: 110 immediate-8/32 ;
M: operand XOR OCT: 061 2-operand ;
GENERIC: CMP ( dst src -- )
M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ;
M: operand CMP OCT: 071 2-operand ;
: IMUL ( dst src -- )
HEX: 0f compile-byte HEX: af 2-operand ;
@ -266,9 +286,6 @@ M: operand AND HEX: 21 2-operand ;
: SHR ( dst src -- ) HEX: c1 BIN: 101 immediate-8 ;
GENERIC: CMP ( dst src -- )
M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ;
M: operand CMP HEX: 39 2-operand ;
: LEA ( dst src -- )
HEX: 8d compile-byte swap register 1-operand ;

67
library/compiler/x86/generator.factor
View File

@ -38,8 +38,8 @@ M: %untag generate-node ( vop -- )
vop-source v>operand BIN: 111 bitnot AND ;
M: %slot generate-node ( vop -- )
! the untagged object is in vop-dest, the tagged slot number
! is in vop-literal.
#! the untagged object is in vop-dest, the tagged slot
#! number is in vop-literal.
dup vop-literal v>operand swap vop-dest v>operand
! turn tagged fixnum slot # into an offset, multiple of 4
over 1 SHR
@ -49,15 +49,15 @@ M: %slot generate-node ( vop -- )
dup unit MOV ;
M: %fast-slot generate-node ( vop -- )
! the tagged object is in vop-dest, the pointer offset is
! in vop-literal. the offset already takes the type tag
! into account, so its just one instruction to load.
#! the tagged object is in vop-dest, the pointer offset is
#! in vop-literal. the offset already takes the type tag
#! into account, so its just one instruction to load.
dup vop-literal swap vop-dest v>operand tuck >r 2list r>
swap MOV ;
M: %set-slot generate-node ( vop -- )
! the untagged object is in vop-dest, the new value is in
! vop-source, the tagged slot number is in vop-literal.
#! the untagged object is in vop-dest, the new value is in
#! vop-source, the tagged slot number is in vop-literal.
dup vop-literal v>operand over vop-dest v>operand
! turn tagged fixnum slot # into an offset, multiple of 4
over 1 SHR
@ -67,22 +67,51 @@ M: %set-slot generate-node ( vop -- )
>r vop-source v>operand r> unit swap MOV ;
M: %fast-set-slot generate-node ( vop -- )
! the tagged object is in vop-dest, the new value is in
! vop-source, the pointer offset is in vop-literal. the
! offset already takes the type tag into account, so its
! just one instruction to load.
#! the tagged object is in vop-dest, the new value is in
#! vop-source, the pointer offset is in vop-literal. the
#! offset already takes the type tag into account, so its
#! just one instruction to load.
dup vop-literal over vop-dest v>operand swap 2list
swap vop-source v>operand MOV ;
\ dispatch [
M: %dispatch generate-node ( vop -- )
#! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the fixnum at the top of the stack.
#! The jump table must immediately follow this macro.
drop
POP-DS
EAX 1 SHR
EAX HEX: ffff ADD just-compiled f rel-address
[ EAX ] JMP
vop-source v>operand dup 1 SHR
dup HEX: ffff ADD just-compiled >r f rel-address
unit JMP
compile-aligned
compiled-offset swap set-compiled-cell ( fixup -- )
] "generator" set-word-prop
compiled-offset r> set-compiled-cell ( fixup -- ) ;
M: %type generate-node ( vop -- )
#! Intrinstic version of type primitive.
<label> "object" set
<label> "f" set
<label> "end" set
vop-source v>operand
! Make a copy
ECX over MOV
! Get the tag
dup tag-mask AND
! Compare with object tag number (3).
dup object-tag CMP
! Jump if the object stores type info in its header
"object" get 0 JE relative
! It doesn't store type info in its header
dup tag-bits SHL
"end" get compile-jump-label
"object" get save-xt
! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9).
ECX object-tag CMP
"f" get 0 JE relative
! The pointer is not equal to 3. Load the object header.
dup ECX object-tag neg 2list MOV
! Headers have tag 3. Clear the tag to turn it into a fixnum.
dup object-tag XOR
"end" get compile-jump-label
"f" get save-xt
! The pointer is equal to 3. Load F_TYPE (9).
f type tag-bits shift MOV
"end" get save-xt ;

8
library/generic/builtin.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: errors hashtables kernel lists namespaces parser
sequences strings words vectors ;
USING: errors hashtables kernel lists math namespaces parser
sequences strings vectors words ;
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
@ -51,3 +51,7 @@ builtin [ 2drop t ] "class<" set-word-prop
: builtin-type ( n -- symbol ) builtins get nth ;
PREDICATE: word builtin metaclass builtin = ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;

2
library/generic/generic.factor
View File

@ -76,7 +76,7 @@ math-internals ;
: define-method ( class generic definition -- )
-rot
over metaclass word? [
word-name " is not a class" append throw
over word-name " is not a class" append throw
] unless
[ "methods" word-prop set-hash ] keep make-generic ;

25
library/inference/types.factor
View File

@ -5,34 +5,15 @@ USING: errors generic interpreter kernel kernel-internals
lists math namespaces strings vectors words sequences
stdio prettyprint ;
: fast-slot? ( -- ? )
#! If the slot number is literal and the object's type is
#! known, we can compile a slot access into a single
#! instruction (x86).
peek-d literal?
peek-next-d value-class builtin-supertypes length 1 = and ;
: fast-slot ( -- )
pop-literal
peek-d value-class builtin-supertypes cons
\ slot [ [ object ] [ object ] ] (consume/produce) ;
: computed-slot ( -- )
"Computed slot access is slower" inference-warning
\ slot dup "infer-effect" word-prop consume/produce ;
\ slot [
[ object fixnum ] ensure-d
fast-slot? [ fast-slot ] [ computed-slot ] ifte
] "infer" set-word-prop
: type-value-map ( value -- )
num-types
[ tuck builtin-type <class-tie> cons ] project-with
[ cdr class-tie-class ] subset ;
: value-types ( value -- list ) value-class builtin-supertypes ;
: literal-type ( -- )
dataflow-drop, pop-d value-class builtin-supertypes car
dataflow-drop, pop-d value-types car
apply-literal ;
: computed-type ( -- )

3
library/inference/words.factor
View File

@ -100,8 +100,7 @@ M: compound apply-word ( word -- )
] ifte ;
: literal-type? ( -- ? )
peek-d value-class builtin-supertypes
dup length 1 = >r [ tuple ] = not r> and ;
peek-d value-types dup length 1 = >r [ tuple ] = not r> and ;
: dynamic-dispatch-warning ( word -- )
"Dynamic dispatch for " swap word-name cat2

9
library/kernel.factor
View File

@ -14,6 +14,7 @@ M: object = eq? ;
GENERIC: clone ( obj -- obj )
M: object clone ;
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
@ -41,3 +42,11 @@ M: object clone ;
os "freebsd" =
os "linux" = or
os "macosx" = or ;
: tag-mask BIN: 111 ; inline
: tag-bits 3 ; inline
: fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline

7
library/test/benchmark/vectors.factor
View File

@ -1,9 +1,4 @@
USE: vectors
USE: kernel
USE: math
USE: compiler
USE: test
USE: sequences
USING: compiler kernel math sequences test vectors ;
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html

3
library/test/compiler/stack.factor
View File

@ -27,6 +27,9 @@ USE: kernel
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
! Test various kill combinations

10
library/ui/gadgets.factor
View File

@ -27,7 +27,7 @@ C: gadget ( shape -- gadget )
gadget-parent [ redraw ] when*
] ifte ;
: relayout* ( gadget -- )
: relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop.
dup gadget-relayout? [
@ -35,12 +35,12 @@ C: gadget ( shape -- gadget )
] [
t over set-gadget-redraw?
t over set-gadget-relayout?
gadget-parent [ relayout* ] when*
gadget-parent [ relayout ] when*
] ifte ;
: relayout ( gadget -- )
: relayout* ( gadget -- )
#! Relayout a gadget and its children.
dup relayout* gadget-children [ relayout ] each ;
dup relayout gadget-children [ relayout* ] each ;
: ?move ( x y gadget quot -- )
>r 3dup shape-pos >r rect> r> = [
@ -56,7 +56,7 @@ C: gadget ( shape -- gadget )
] r> ifte ; inline
: resize-gadget ( w h gadget -- )
[ [ resize-shape ] keep relayout ] ?resize ;
[ [ resize-shape ] keep relayout* ] ?resize ;
: paint-prop ( gadget key -- value )
over [