diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor index 01beb90a71..b2e0ca2ef3 100644 --- a/library/compiler/assembly-x86.factor +++ b/library/compiler/assembly-x86.factor @@ -30,6 +30,7 @@ USE: kernel USE: compiler USE: math USE: stack +USE: combinators : EAX 0 ; : ECX 1 ; @@ -48,16 +49,31 @@ USE: stack : I>R ( imm reg -- ) #! MOV TO - HEX: b8 + compile-byte compile-cell ; + dup EAX = [ + drop HEX: b8 compile-byte + ] [ + HEX: 8b compile-byte + 3 shift BIN: 101 bitor compile-byte + ] ifte compile-cell ; : [I]>R ( imm reg -- ) #! MOV INDIRECT TO - HEX: a1 + compile-byte compile-cell ; + dup EAX = [ + drop HEX: a1 compile-byte + ] [ + HEX: 8d compile-byte + 3 shift BIN: 101 bitor compile-byte + ] ifte compile-cell ; : I>[R] ( imm reg -- ) #! MOV TO INDIRECT HEX: c7 compile-byte compile-byte compile-cell ; +: R>[I] ( reg imm -- ) + #! MOV INDIRECT TO . + #! Actually only works with EAX (?) + swap HEX: a3 + compile-byte compile-cell ; + : [R]>R ( reg reg -- ) #! MOV INDIRECT TO . HEX: 8b compile-byte swap 3 shift bitor compile-byte ; @@ -91,16 +107,26 @@ USE: stack 4 DATASTACK I+[I] ECX POP ; -: (JMP) ( xt opcode -- ) +: POP-DS ( -- ) + #! Pop datastack into EAX. + ( ECX PUSH ) + DATASTACK ECX I>R + ! LEA... + HEX: 8d compile-byte HEX: 41 compile-byte HEX: fc compile-byte + EAX DATASTACK R>[I] + EAX EAX [R]>R + ( ECX POP ) ; + +: (JUMP) ( xt opcode -- ) #! JMP, CALL insn is 5 bytes long #! addr is relative to *after* insn compile-byte compiled-offset 4 + - compile-cell ; -: JMP ( -- ) - HEX: e9 (JMP) ; +: JUMP ( -- ) + HEX: e9 (JUMP) ; : CALL ( -- ) - HEX: e8 (JMP) ; + HEX: e8 (JUMP) ; : RET ( -- ) HEX: c3 compile-byte ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 14fde7ddb1..8bab12a5bc 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -39,9 +39,8 @@ USE: logic USE: kernel USE: vectors -: compile-word ( word -- ) - #! Compile a JMP at the end (tail call optimization) - word-xt "compile-last" get [ JMP ] [ CALL ] ifte ; +: pop-literal ( -- obj ) + "compile-datastack" get vector-pop ; : compile-literal ( obj -- ) dup fixnum? [ @@ -55,11 +54,27 @@ USE: vectors 0 swap set-vector-length ; : postpone ( obj -- ) + #! Literals are not compiled immediately, so that words like + #! ifte with special compilation behavior can work. "compile-datastack" get vector-push ; +: compile-simple-word ( word -- ) + #! Compile a JMP at the end (tail call optimization) + commit-literals word-xt + "compile-last" get [ JUMP ] [ CALL ] ifte ; + +: compile-word ( word -- ) + #! If a word has a compiling property, then it has special + #! compilation behavior. + "compiling" over word-property dup [ + nip call + ] [ + drop compile-simple-word + ] ifte ; + : compile-atom ( obj -- ) [ - [ word? ] [ commit-literals compile-word ] + [ word? ] [ compile-word ] [ drop t ] [ postpone ] ] cond ; diff --git a/native/error.c b/native/error.c index f0a77ee833..29ce6771d6 100644 --- a/native/error.c +++ b/native/error.c @@ -15,6 +15,8 @@ void critical_error(char* msg, CELL tagged) void fix_stacks(void) { + fprintf(stderr,"%x\n",ds); + fprintf(stderr,"%x\n",ds_bot); if(STACK_UNDERFLOW(ds,ds_bot) || STACK_OVERFLOW(ds,ds_bot)) reset_datastack();