FFI:\r
- is signed -vs- unsigned pointers an issue?\r
\r
+- BIN: 2: bad\r
+\r
- symbols are not primitives\r
+- compiled? messy\r
+- compiler: drop literal peephole optimization\r
+- compiler: type-of { ... } call\r
+ type-of { ... } execute\r
+ arithmetic-type { ... } call\r
+ arithmetic-type { ... } execute\r
+- ditch ds/cs envs, just use dlsym instead\r
+- getenv/setenv: if literal arg, compile as a load/store\r
+- inline words\r
+- raise an error when compiling something we can't\r
+ call, datastack/callstack, set-datastack/callstack,\r
+ execute\r
\r
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
: UNBOX ( name -- )
#! Move top of datastack to C stack.
- dlsym-self CALL JUMP-FIXUP
- EAX PUSH-R ;
+ SELF-CALL EAX PUSH-R ;
: BOX ( name -- )
#! Move EAX to datastack.
- 24 ESP R-I
- EAX PUSH-R
- dlsym-self CALL JUMP-FIXUP
- 28 ESP R+I ;
+ EAX PUSH-R SELF-CALL 4 ESP R+I ;
: PARAMETERS ( params -- count )
#! Generate code for boxing a list of C types.
: compile-cell ( n -- )
compiled-offset set-compiled-cell
compiled-offset cell + set-compiled-offset ;
-
-: DATASTACK ( -- ptr )
- #! A pointer to a pointer to the datastack top.
- 11 getenv ;
-
-: CALLSTACK ( -- ptr )
- #! A pointer to a pointer to the callstack top.
- 12 getenv ;
: ESI 6 ;
: EDI 7 ;
+: byte? -128 127 between? ;
+
+: eax/other ( reg quot quot -- )
+ #! Execute first quotation if reg is EAX, second quotation
+ #! otherwise, leaving reg on the stack.
+ pick EAX = [ drop nip call ] [ nip call ] ifte ;
+
+: byte/eax/cell ( imm reg byte eax cell -- )
+ #! Assemble an instruction with 3 forms; byte operand, any
+ #! register; eax register, cell operand; other register,
+ #! cell operand.
+ >r >r >r >r dup byte? [
+ r> r> call r> drop r> drop compile-byte
+ ] [
+ r> dup EAX = [
+ drop r> drop r> call r> drop compile-cell
+ ] [
+ r> drop r> drop r> call compile-cell
+ ] ifte
+ ] ifte ;
+
: MOD-R/M ( r/m reg/opcode mod -- )
+ #! MOD-R/M is MOD REG/OPCODE R/M
6 shift swap 3 shift bitor bitor compile-byte ;
: PUSH-R ( reg -- )
HEX: 50 + compile-byte ;
+: PUSH-[R] ( reg -- )
+ HEX: ff compile-byte BIN: 110 0 MOD-R/M ;
+
: PUSH-I ( imm -- )
HEX: 68 compile-byte compile-cell ;
: [I]>R ( imm reg -- )
#! MOV INDIRECT <imm> TO <reg>
- dup EAX = [
- drop HEX: a1 compile-byte
+ [
+ HEX: a1 compile-byte
] [
HEX: 8b compile-byte
BIN: 101 swap 0 MOD-R/M
- ] ifte compile-cell ;
+ ] eax/other compile-cell ;
: I>[R] ( imm reg -- )
#! MOV <imm> TO INDIRECT <reg>
: R>[I] ( reg imm -- )
#! MOV <reg> TO INDIRECT <imm>.
- over EAX = [
- nip HEX: a3 compile-byte
+ swap [
+ HEX: a3 compile-byte
] [
HEX: 89 compile-byte
- swap BIN: 101 swap 0 MOD-R/M
- ] ifte compile-cell ;
+ BIN: 101 swap 0 MOD-R/M
+ ] eax/other compile-cell ;
: R>R ( reg reg -- )
#! MOV <reg> TO <reg>.
compile-cell
compile-cell ;
+: EAX+/PARTIAL ( -- fixup )
+ #! This is potentially bad. In the compilation of
+ #! generic and 2generic, we need to add something which is
+ #! only known later.
+ #!
+ #! Returns address of 32-bit immediate.
+ HEX: 05 compile-byte compiled-offset 0 compile-cell ;
+
: R+I ( imm reg -- )
#! ADD <imm> TO <reg>, STORE RESULT IN <reg>
- over -128 127 between? [
+ [
HEX: 83 compile-byte
0 BIN: 11 MOD-R/M
- compile-byte
] [
- dup EAX = [
- drop HEX: 05 compile-byte
- ] [
- HEX: 81 compile-byte
- 0 BIN: 11 MOD-R/M
- ] ifte
- compile-cell
- ] ifte ;
+ HEX: 05 compile-byte
+ ] [
+ HEX: 81 compile-byte
+ 0 BIN: 11 MOD-R/M
+ ] byte/eax/cell ;
: R-I ( imm reg -- )
#! SUBTRACT <imm> FROM <reg>, STORE RESULT IN <reg>
- over -128 127 between? [
+ [
HEX: 83 compile-byte
BIN: 101 BIN: 11 MOD-R/M
- compile-byte
] [
- dup EAX = [
- drop HEX: 2d compile-byte
- ] [
- HEX: 81 compile-byte
- BIN: 101 BIN: 11 MOD-R/M
- ] ifte
- compile-cell
- ] ifte ;
+ HEX: 2d compile-byte
+ ] [
+ HEX: 81 compile-byte
+ BIN: 101 BIN: 11 MOD-R/M
+ ] byte/eax/cell ;
+
+: R<<I ( imm reg -- )
+ #! SHIFT <reg> BY <imm>, STORE RESULT IN <reg>
+ HEX: c1 compile-byte
+ BIN: 100 BIN: 11 MOD-R/M
+ compile-byte ;
: CMP-I-[R] ( imm reg -- )
#! There are two forms of CMP we assemble
#! 83 38 03 cmpl $0x3,(%eax)
#! 81 38 33 33 33 00 cmpl $0x333333,(%eax)
- over -128 127 between? [
+ over byte? [
HEX: 83 compile-byte
BIN: 111 0 MOD-R/M
compile-byte
#! Push address of branch for fixup
HEX: e9 compile-byte (JUMP) ;
+: JUMP-[R] ( reg -- )
+ #! JUMP TO INDIRECT <reg>.
+ HEX: ff compile-byte BIN: 100 0 MOD-R/M ;
+
: CALL ( -- fixup )
HEX: e8 compile-byte (JUMP) ;
+: CALL-[R] ( reg -- )
+ #! CALL INDIRECT <reg>.
+ HEX: ff compile-byte BIN: 10 0 MOD-R/M ;
+
: JE ( -- fixup )
HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
+USE: alien
+
+: DATASTACK ( -- ptr )
+ #! A pointer to a pointer to the datastack top.
+ "ds" dlsym-self ;
+
+: CALLSTACK ( -- ptr )
+ #! A pointer to a pointer to the callstack top.
+ "cs" dlsym-self ;
: LITERAL ( cell -- )
#! Push literal on data stack.
DATASTACK EAX [I]>R
4 EAX R-I
EAX DATASTACK R>[I] ;
+
+: SELF-CALL ( name -- )
+ #! Call named C function in Factor interpreter executable.
+ dlsym-self CALL JUMP-FIXUP ;
+
+: TYPE-OF ( -- )
+ #! Pop datastack, store type # in EAX.
+ POP-DS
+ EAX PUSH-[R]
+ "type_of" SELF-CALL
+ 4 ESI R-I ;
USE: math
USE: lists
-: compile-f-test ( -- fixup )
+: F-TEST ( -- fixup )
#! Push addr where we write the branch target address.
POP-DS
! ptr to condition is now in EAX
JE ;
: branch-target ( fixup -- )
- cell compile-aligned compiled-offset swap JUMP-FIXUP ;
+ compiled-offset swap JUMP-FIXUP ;
-: compile-else ( fixup -- fixup )
+: ELSE ( fixup -- fixup )
#! Push addr where we write the branch target address,
#! and fixup branch target address from compile-f-test.
#! Push f for the fixup if we're tail position.
tail? [ RET f ] [ JUMP ] ifte swap branch-target ;
-: compile-end-if ( fixup -- )
+: END-IF ( fixup -- )
tail? [ drop RET ] [ branch-target ] ifte ;
-: compile-ifte ( -- )
+: compile-ifte ( compile-time: true false -- )
pop-literal pop-literal commit-literals
- compile-f-test >r
+ F-TEST >r
( t -- ) compile-quot
- r> compile-else >r
+ r> ELSE >r
( f -- ) compile-quot
- r> compile-end-if ;
+ r> END-IF ;
+
+: TABLE-JUMP ( start-fixup -- end-fixup )
+ #! The 32-bit address of the code after the jump table
+ #! should be written to end-fixup.
+ #! The jump table must immediately follow this macro.
+ tail? [ 0 ] [ 0 PUSH-I compiled-offset 4 - ] ifte >r
+ ( start-fixup r:end-fixup )
+ EAX JUMP-[R]
+ compiled-offset swap set-compiled-cell ( update the ADD )
+ r> ;
+
+: BEGIN-JUMP-TABLE ( -- end-fixup )
+ #! Compile a piece of code that jumps to an offset in a
+ #! jump table indexed by the type of the Factor object in
+ #! EAX.
+ TYPE-OF
+ 2 EAX R<<I
+ EAX+/PARTIAL
+ TABLE-JUMP ;
+
+: END-JUMP-TABLE ( end-fixup -- )
+ compiled-offset dup 0 = [
+ 2drop
+ ] [
+ set-compiled-cell ( update the PUSH )
+ ] ifte ;
+
+: compile-generic ( compile-time: vtable -- )
+ #! Compile a faster alternative to
+ #! : generic ( obj vtable -- )
+ #! >r dup type r> vector-nth execute ;
+ BEGIN-JUMP-TABLE
+ ! write table now
+ END-JUMP-TABLE ;
[
[ ifte compile-ifte ]
+ [ generic compile-generic ]
] [
unswons "compiling" set-word-property
] each
0 emit ;
! This is to handle mutually recursive words
-! It is a hack. A recursive word in the cdr of a
-! cons doesn't work! This never happends though.
-!
-! Eg : foo [ 5 | foo ] ;
-
-: fixup-word-later ( word -- )
- image vector-length cons "word-fixups" get vector-push ;
-: fixup-word ( where word -- )
+: fixup-word ( word -- offset )
dup pooled-object dup [
- nip swap fixup
+ nip
] [
drop "Not in image: " swap word-name cat2 throw
] ifte ;
: fixup-words ( -- )
- "word-fixups" get [ unswons fixup-word ] vector-each ;
+ "image" get [
+ dup word? [ fixup-word ] when
+ ] vector-map "image" set ;
: 'word ( word -- pointer )
- dup pooled-object dup [
- nip
- ] [
- drop
- ! Remember where we are, and add the reference later
- dup fixup-word-later
- ] ifte ;
+ dup pooled-object dup [ nip ] [ drop ] ifte ;
( Conses )
dup word-name "name" swons ,
dup word-vocabulary "vocabulary" swons ,
- "parsing" over word-property [ t "parsing" swons , ] when
+ "parsing" word-property [ t "parsing" swons , ] when
- drop
,] ' ;
: (worddef,) ( word primitive parameter -- )
over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte
] ifte ;
-: cons-hashcode ( cons count -- hash )
+: (cons-hashcode) ( cons count -- hash )
dup 0 = [
2drop 0
] [
over cons? [
pred >r uncons r> tuck
- cons-hashcode >r
- cons-hashcode r>
+ (cons-hashcode) >r
+ (cons-hashcode) r>
bitxor
] [
drop hashcode
] ifte
] ifte ;
+: cons-hashcode ( cons -- hash )
+ 4 (cons-hashcode) ;
+
: list>vector ( list -- vector )
dup length <vector> swap [ over vector-push ] each ;
intern dup [ [ "def" get ] bind ] when
] unless ;
-: word-property ( pname word -- pvalue )
- [ get ] bind ;
+: word-property ( word pname -- pvalue )
+ swap [ get ] bind ;
-: set-word-property ( pvalue pname word -- )
- [ set ] bind ;
+: set-word-property ( pvalue word pname -- )
+ swap [ set ] bind ;
: redefine ( word def -- )
swap [ "def" set ] bind ;
! 'generic words' system will be built later.
: generic ( obj vtable -- )
- over type swap vector-nth call ;
+ >r dup type r> vector-nth execute ;
-: 2generic ( n n map -- )
+: 2generic ( n n vtable -- )
>r 2dup arithmetic-type r> vector-nth execute ;
+: default-hashcode drop 0 ;
+
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.
{
- [ ]
- [ word-hashcode ]
- [ 4 cons-hashcode ]
- [ drop 0 ]
- [ >fixnum ]
- [ >fixnum ]
- [ drop 0 ]
- [ drop 0 ]
- [ drop 0 ]
- [ vector-hashcode ]
- [ str-hashcode ]
- [ sbuf-hashcode ]
- [ drop 0 ]
- [ >fixnum ]
- [ >fixnum ]
- [ drop 0 ]
- [ drop 0 ]
+ nop
+ word-hashcode
+ cons-hashcode
+ default-hashcode
+ >fixnum
+ >fixnum
+ default-hashcode
+ default-hashcode
+ default-hashcode
+ vector-hashcode
+ str-hashcode
+ sbuf-hashcode
+ default-hashcode
+ >fixnum
+ >fixnum
+ default-hashcode
+ default-hashcode
} generic ;
-
IN: math DEFER: number= ( defined later... )
IN: kernel
: = ( obj obj -- ? )
#! Push t if a is isomorphic to b.
{
- [ number= ]
- [ eq? ]
- [ cons= ]
- [ eq? ]
- [ number= ]
- [ number= ]
- [ eq? ]
- [ eq? ]
- [ eq? ]
- [ vector= ]
- [ str= ]
- [ sbuf= ]
- [ eq? ]
- [ number= ]
- [ number= ]
- [ eq? ]
- [ eq? ]
+ number=
+ eq?
+ cons=
+ eq?
+ number=
+ number=
+ eq?
+ eq?
+ eq?
+ vector=
+ str=
+ sbuf=
+ eq?
+ number=
+ number=
+ eq?
+ eq?
} generic ;
: 2= ( a b c d -- ? )
IN: stack
USE: vectors
+: nop ( -- ) ;
: 2drop ( x x -- ) drop drop ;
: 3drop ( x x x -- ) drop drop drop ;
: 2dup ( x y -- x y x y ) over over ;
IN: scratchpad
USE: compiler
+USE: stack
0 EAX I>R
0 ECX I>R
4 ECX R-I
65535 EAX R-I
65535 ECX R-I
+
+EAX PUSH-R
+ECX PUSH-R
+EAX PUSH-[R]
+ECX PUSH-[R]
+65535 PUSH-I
+
+EAX JUMP-[R]
+ECX JUMP-[R]
USE: combinators
USE: words
-"Hi." USE: stdio print
-
: no-op ; compiled
[ ] [ no-op ] unit-test
DEFER: countdown-b
-: countdown-a ( n -- ) dup 0 eq? [ drop ] [ pred countdown-b ] ifte ;
-: countdown-b ( n -- ) dup 0 eq? [ drop ] [ pred countdown-a ] ifte ; compiled
+: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] ifte ;
+: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] ifte ; compiled
[ ] [ 10 countdown-b ] unit-test
#define BOOT_ENV 8
#define RUNQUEUE_ENV 9 /* used by library only */
#define ARGS_ENV 10
-#define DS_ENV 11 /* ptr to base addr of datastack */
-#define CS_ENV 12 /* ptr to base addr of callstack */
/* Profiling timer */
struct itimerval prof_timer;
{
ds_bot = (CELL)alloc_guarded(STACK_SIZE);
reset_datastack();
- userenv[DS_ENV] = tag_integer((CELL)&ds);
cs_bot = (CELL)alloc_guarded(STACK_SIZE);
reset_callstack();
- userenv[CS_ENV] = tag_integer((CELL)&cs);
callframe = userenv[BOOT_ENV];
}
projects / factor.git / commitdiff