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

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

release
U-3ADF\Administrator 2007-09-23 20:16:52 +02:00
parent 545e58873e 94bfbbde2f
commit 26f7671a54
56 changed files with 416 additions and 352 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -9,3 +9,4 @@ Factor/factor
*.lib
*.image
*.dylib
factor

0
Factor.app/Contents/MacOS/.dummy Normal file
View File

64
Makefile
View File

@ -44,21 +44,20 @@ EXE_OBJS = $(PLAF_EXE_OBJS)
default:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "freebsd-x86"
@echo "freebsd-amd64"
@echo "linux-x86"
@echo "linux-amd64"
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
@echo "linux-ppc"
@echo "linux-arm"
@echo "openbsd-x86"
@echo "openbsd-amd64"
@echo "macosx-x86"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-ppc"
@echo "solaris-x86"
@echo "solaris-amd64"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "windows-ce-arm"
@echo "windows-ce-x86"
@echo "windows-nt-x86"
@echo "windows-nt-x86-32"
@echo ""
@echo "Additional modifiers:"
@echo ""
@ -67,17 +66,17 @@ default:
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86
openbsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86.32
openbsd-amd64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.amd64
openbsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86
freebsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.32
freebsd-amd64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.amd64
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
macosx-freetype:
ln -sf libfreetype.6.dylib \
@ -86,14 +85,14 @@ macosx-freetype:
macosx-ppc: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86
macosx-x86-32: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.32
linux-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86
linux-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32
linux-amd64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.amd64
linux-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.ppc
@ -101,21 +100,18 @@ linux-ppc:
linux-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.arm
solaris-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86
solaris-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.32
solaris-amd64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.amd64
solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
windows-nt-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86
windows-nt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
windows-ce-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
windows-ce-x86:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.x86
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor

2
core/bootstrap/image/image.factor
View File

@ -32,7 +32,7 @@ IN: bootstrap.image
: -1-offset 9 ; inline
: array-start 2 bootstrap-cells object tag-number - ;
: scan@ array-start 4 - ;
: scan@ array-start bootstrap-cell - ;
: wrapper@ bootstrap-cell object tag-number - ;
: word-xt@ 8 bootstrap-cells object tag-number - ;
: quot-array@ bootstrap-cell object tag-number - ;

4
core/cpu/x86/32/32.factor
View File

@ -206,10 +206,10 @@ M: x86-backend %box-small-struct ( size -- )
M: x86-backend %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
ESP cell temp@ [+] EAX MOV ;
cell temp@ EAX MOV ;
M: x86-backend %alien-indirect ( -- )
ESP cell temp@ [+] CALL ;
cell temp@ CALL ;
M: x86-backend %alien-callback ( quot -- )
4 [

104
core/cpu/x86/32/bootstrap.factor
View File

@ -1,106 +1,18 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs ;
IN: bootstrap.x86.32
cpu.x86.assembler layouts vocabs parser ;
IN: bootstrap.x86
4 \ cell set
big-endian off
1 jit-code-format set
: arg0 EAX ;
: arg1 EDX ;
: stack-reg ESP ;
: ds-reg ESI ;
: scan-reg EBX ;
: xt-reg ECX ;
: scan-save ESP 12 [+] ;
: fixnum>slot@ arg0 1 SAR ;
: next-frame@ -44 ;
[
EAX EAX quot-array@ [+] MOV ! load array
scan-reg EAX 1 [+] LEA ! initialize scan pointer
] { } make jit-setup set
[
xt-reg PUSH ! save XT
xt-reg ESP -44 [+] LEA ! compute forward chain pointer
xt-reg PUSH ! save forward chain pointer
EAX PUSH ! save array
ESP 16 SUB ! reserve space for scan-save
] { } make jit-prolog set
: advance-scan scan-reg 4 ADD ;
[
advance-scan
ds-reg 4 ADD ! increment datastack pointer
EAX scan-reg [] MOV ! load literal
ds-reg [] EAX MOV ! store literal on datastack
] { } make jit-push-literal set
[
advance-scan
ds-reg 4 ADD ! increment datastack pointer
EAX scan-reg [] MOV ! load wrapper
EAX dup wrapper@ [+] MOV ! load wrapper-obj slot
ds-reg [] EAX MOV ! store literal on datastack
] { } make jit-push-wrapper set
[
EDX ESP MOV ! pass callstack pointer as arg 2
] { } make jit-word-primitive-jump set
[
EDX ESP -4 [+] LEA ! pass callstack pointer as arg 2
] { } make jit-word-primitive-call set
[
EAX scan-reg 4 [+] MOV ! load word
EAX word-xt@ [+] JMP ! jump to word XT
] { } make jit-word-jump set
[
advance-scan
scan-save scan-reg MOV ! save scan pointer
EAX scan-reg [] MOV ! load word
EAX word-xt@ [+] CALL ! call word XT
scan-reg scan-save MOV ! restore scan pointer
] { } make jit-word-call set
: load-branch
EAX ds-reg [] MOV ! load boolean
ds-reg 4 SUB ! pop boolean
EAX \ f tag-number CMP ! compare it with f
EAX scan-reg 8 [+] CMOVE ! load false branch if equal
EAX scan-reg 4 [+] CMOVNE ! load true branch if not equal
scan-reg 12 ADD ! advance scan pointer
xt-reg EAX quot-xt@ [+] MOV ! load quotation-xt
;
[
load-branch
xt-reg JMP
] { } make jit-if-jump set
[
load-branch
ESP [] scan-reg MOV ! save scan pointer
xt-reg CALL ! call quotation
scan-reg ESP [] MOV ! restore scan pointer
] { } make jit-if-call set
[
EAX ds-reg [] MOV ! load index
EAX 1 SAR ! turn it into an array offset
ds-reg 4 SUB ! pop index
EAX scan-reg 4 [+] ADD ! compute quotation location
EAX EAX array-start [+] MOV ! load quotation
xt-reg EAX quot-xt@ [+] MOV ! load quotation-xt
xt-reg JMP ! execute quotation
] { } make jit-dispatch set
[
ESP 28 ADD ! unwind stack frame
] { } make jit-epilog set
[ 0 RET ] { } make jit-return set
"bootstrap.x86.32" forget-vocab
"resource:core/cpu/x86/bootstrap.factor" run-file

12
core/cpu/x86/64/64.factor
View File

@ -13,11 +13,13 @@ PREDICATE: x86-backend amd64-backend
M: amd64-backend ds-reg R14 ;
M: amd64-backend rs-reg R15 ;
M: amd64-backend stack-reg RSP ;
M: x86-backend xt-reg RCX ;
M: x86-backend stack-save-reg RSI ;
M: temp-reg v>operand drop R11 ;
M: temp-reg v>operand drop RBX ;
M: int-regs return-reg drop RAX ;
M: int-regs vregs drop { RAX RCX RDX RSI RDI RBP R8 R9 R10 } ;
M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
@ -144,17 +146,17 @@ M: amd64-backend %alien-indirect ( -- )
cell temp@ CALL ;
M: amd64-backend %alien-callback ( quot -- )
RDI load-indirect "run_callback" f compile-c-call ;
RDI load-indirect "c_to_factor" f compile-c-call ;
M: amd64-backend %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
temp@ RDI MOV
cell temp@ RDI MOV
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
RDI temp@ MOV
RDI cell temp@ MOV
! Unbox former top of data stack to return registers
unbox-return ;

18
core/cpu/x86/64/bootstrap.factor
View File

@ -1,4 +1,18 @@
USING: bootstrap.image.private kernel namespaces system ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ;
IN: bootstrap.x86
8 \ cell set
big-endian off
: arg0 RDI ;
: arg1 RSI ;
: stack-reg RSP ;
: ds-reg R14 ;
: scan-reg RBX ;
: xt-reg RCX ;
: fixnum>slot@ ;
: next-frame@ -88 ;
"resource:core/cpu/x86/bootstrap.factor" run-file

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

@ -150,13 +150,13 @@ M: x86-backend small-enough? ( n -- ? )
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
: temp@ \ stack-frame get swap - ;
: temp@ stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
stack-frame* cell + +
] [
temp@
\ stack-frame get swap -
] ?if ;
HOOK: %unbox-struct-1 compiler-backend ( -- )

102
core/cpu/x86/bootstrap.factor Normal file
View File

@ -0,0 +1,102 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs math ;
IN: bootstrap.x86
big-endian off
1 jit-code-format set
: scan-save stack-reg 3 bootstrap-cells [+] ;
[
arg0 arg0 quot-array@ [+] MOV ! load array
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
] { } make jit-setup set
[
xt-reg PUSH ! save XT
xt-reg stack-reg next-frame@ [+] LEA ! compute forward chain pointer
xt-reg PUSH ! save forward chain pointer
arg0 PUSH ! save array
stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save
] { } make jit-prolog set
: advance-scan scan-reg bootstrap-cell ADD ;
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load literal
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load wrapper
arg0 dup wrapper@ [+] MOV ! load wrapper-obj slot
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-wrapper set
[
arg1 stack-reg MOV ! pass callstack pointer as arg 2
] { } make jit-word-primitive-jump set
[
arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2
] { } make jit-word-primitive-call set
[
arg0 scan-reg bootstrap-cell [+] MOV ! load word
arg0 word-xt@ [+] JMP ! jump to word XT
] { } make jit-word-jump set
[
advance-scan
scan-save scan-reg MOV ! save scan pointer
arg0 scan-reg [] MOV ! load word
arg0 word-xt@ [+] CALL ! call word XT
scan-reg scan-save MOV ! restore scan pointer
] { } make jit-word-call set
: load-branch
arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare it with f
arg0 scan-reg 2 bootstrap-cells [+] CMOVE ! load false branch if equal
arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal
scan-reg 3 bootstrap-cells ADD ! advance scan pointer
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt
;
[
load-branch
xt-reg JMP
] { } make jit-if-jump set
[
load-branch
stack-reg [] scan-reg MOV ! save scan pointer
xt-reg CALL ! call quotation
scan-reg stack-reg [] MOV ! restore scan pointer
] { } make jit-if-call set
[
arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 scan-reg bootstrap-cell [+] ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt
xt-reg JMP ! execute quotation
] { } make jit-dispatch set
[
stack-reg 7 bootstrap-cells ADD ! unwind stack frame
] { } make jit-epilog set
[ 0 RET ] { } make jit-return set
"bootstrap.x86" forget-vocab

67
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -71,29 +71,38 @@ IN: cpu.x86.intrinsics
} define-intrinsic
! Slots
: %slot-literal-known-tag
"obj" operand
"n" get cells
"obj" operand-tag - [+] ;
: %slot-literal-any-tag
"obj" operand %untag
"obj" operand "n" get cells [+] ;
: %slot-any
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
\ slot {
! Slot number is literal and the tag is known
{
[ "obj" operand %slot-literal-known-tag MOV ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +output+ { "obj" } }
}
}
! Slot number is literal
{
[
"obj" operand %untag
! load slot value
"obj" operand dup "n" get cells [+] MOV
] H{
[ "obj" operand %slot-literal-any-tag MOV ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
{ +output+ { "obj" } }
}
}
! Slot number in a register
{
[
"obj" operand %untag
! turn tagged fixnum slot # into an offset,
! multiple of 4
"n" operand fixnum>slot@
! load slot value
"obj" operand dup "n" operand [+] MOV
] H{
[ "obj" operand %slot-any MOV ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +output+ { "obj" } }
{ +clobber+ { "n" } }
@ -105,38 +114,28 @@ IN: cpu.x86.intrinsics
#! Mark the card pointed to by vreg.
"val" operand-immediate? "obj" get fresh-object? or [
"obj" operand card-bits SHR
"scratch" operand HEX: ffffffff MOV
"cards_offset" f rc-absolute-cell rel-dlsym
"scratch" operand dup [] MOV
"scratch" operand "obj" operand [+] card-mark OR
"cards_offset" f %alien-global
temp-reg v>operand "obj" operand [+] card-mark OR
] unless ;
\ set-slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +clobber+ { "obj" } }
}
}
! Slot number is literal
{
[
"obj" operand %untag
! store new slot value
"obj" operand "n" get cells [+] "val" operand MOV
generate-write-barrier
] H{
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "obj" } }
}
}
! Slot number in a register
{
[
! turn tagged fixnum slot # into an offset
"n" operand fixnum>slot@
"obj" operand %untag
! store new slot value
"obj" operand "n" operand [+] "val" operand MOV
! reuse register
"n" get "scratch" set
generate-write-barrier
] H{
[ %slot-any "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +clobber+ { "obj" "n" } }
}

3
extra/factory/factory-menus
View File

@ -1,7 +1,8 @@
! -*-factor-*-
USING: kernel unix vars mortar slot-accessors
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu ;
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
factory.commands factory.load ;
IN: factory

1
extra/factory/factory-rc
View File

@ -4,6 +4,7 @@ USING: kernel mortar x
x.widgets.wm.root
x.widgets.wm.workspace
x.widgets.wm.unmapped-frames-menu
factory.load
tty-server ;
IN: factory

14
extra/http/server/responders/responders.factor
View File

@ -126,13 +126,7 @@ SYMBOL: max-post-request
#! Add a responder object to the list.
"responder" over at responders get set-at ;
: add-simple-responder ( name quot -- )
[
[ drop ] swap append dup "get" set "post" set
"responder" set
] H{ } make-assoc add-responder ;
: make-responder ( quot -- responder )
: make-responder ( quot -- )
#! quot has stack effect ( url -- )
[
[
@ -151,6 +145,12 @@ SYMBOL: max-post-request
call
] H{ } make-assoc add-responder ;
: add-simple-responder ( name quot -- )
[
[ drop ] swap append dup "get" set "post" set
"responder" set
] make-responder ;
: vhost ( name -- vhost )
vhosts get at [ "default" vhost ] unless* ;

7
extra/io/unix/launcher/launcher.factor
View File

@ -9,16 +9,15 @@ USE: unix
: with-fork ( quot -- pid )
fork [ zero? -rot if ] keep ; inline
: prepare-execve ( args -- cmd args envp )
: prepare-execvp ( args -- cmd args )
#! Doesn't free any memory, so we only call this word
#! after forking.
[ malloc-char-string ] map
[ first ] keep
f add >c-void*-array
f ;
f add >c-void*-array ;
: (spawn-process) ( args -- )
[ prepare-execve execve ] catch 1 exit ;
[ prepare-execvp execvp ] catch 1 exit ;
: spawn-process ( args -- pid )
[ (spawn-process) ] [ drop ] with-fork ;

5
extra/json/writer/writer.factor
View File

@ -21,6 +21,11 @@ M: string json-print ( obj -- )
M: number json-print ( num -- )
number>string write ;
! sequence and number overlap, we provide an explicit
! disambiguation method
M: integer json-print ( num -- )
number>string write ;
M: sequence json-print ( array -- string )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;

1
extra/unix/unix.factor
View File

@ -107,6 +107,7 @@ FUNCTION: void close ( int fd ) ;
FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int dup2 ( int oldd, int newd ) ;
! FUNCTION: int dup ( int oldd ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchmod ( int fd, mode_t mode ) ;

2
vm/Config.amd64
View File

@ -1,2 +0,0 @@
BOOT_ARCH = amd64
PLAF_DLL_OBJS += vm/cpu-amd64.o

1
vm/Config.arm
View File

@ -1,2 +1 @@
BOOT_ARCH = arm
PLAF_DLL_OBJS += vm/cpu-arm.o

2
vm/Config.freebsd.amd64 → vm/Config.freebsd.x86.32
View File

@ -1,2 +1,2 @@
include vm/Config.freebsd
include vm/Config.amd64
include vm/Config.x86.32

2
vm/Config.freebsd.x86 → vm/Config.freebsd.x86.64
View File

@ -1,2 +1,2 @@
include vm/Config.freebsd
include vm/Config.x86
include vm/Config.x86.64

2
vm/Config.linux.x86
View File

@ -1,2 +0,0 @@
include vm/Config.linux
include vm/Config.x86

2
vm/Config.linux.x86.32 Normal file
View File

@ -0,0 +1,2 @@
include vm/Config.linux
include vm/Config.x86.32

2
vm/Config.linux.amd64 → vm/Config.linux.x86.64
View File

@ -1,3 +1,3 @@
include vm/Config.linux
include vm/Config.amd64
include vm/Config.x86.64
LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib

2
vm/Config.macosx.x86 → vm/Config.macosx.x86.32
View File

@ -1,2 +1,2 @@
include vm/Config.macosx
include vm/Config.x86
include vm/Config.x86.32

2
vm/Config.openbsd.amd64 → vm/Config.openbsd.x86.32
View File

@ -1,2 +1,2 @@
include vm/Config.openbsd
include vm/Config.amd64
include vm/Config.x86.32

2
vm/Config.openbsd.x86 → vm/Config.openbsd.x86.64
View File

@ -1,2 +1,2 @@
include vm/Config.openbsd
include vm/Config.x86
include vm/Config.x86.64

1
vm/Config.ppc
View File

@ -1,2 +1 @@
BOOT_ARCH = ppc
PLAF_DLL_OBJS += vm/cpu-ppc.o

2
vm/Config.solaris.amd64 → vm/Config.solaris.x86.32
View File

@ -1,2 +1,2 @@
include vm/Config.solaris
include vm/Config.amd64
include vm/Config.x86.32

2
vm/Config.solaris.x86 → vm/Config.solaris.x86.64
View File

@ -1,2 +1,2 @@
include vm/Config.solaris
include vm/Config.x86
include vm/Config.x86.64

2
vm/Config.windows.ce.x86
View File

@ -1,2 +0,0 @@
#CC = x86-wince-mingw32ce-gcc
include vm/Config.windows.ce vm/Config.x86

2
vm/Config.windows.nt.x86 → vm/Config.windows.nt.x86.32
View File

@ -4,4 +4,4 @@ DLL_SUFFIX=-nt
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
include vm/Config.x86 vm/Config.windows
include vm/Config.x86.32 vm/Config.windows

2
vm/Config.x86 → vm/Config.x86.32
View File

@ -1,5 +1,5 @@
BOOT_ARCH = x86
PLAF_DLL_OBJS += vm/cpu-x86.o
PLAF_DLL_OBJS += vm/cpu-x86.32.o
# gcc bug workaround
CFLAGS += -fno-builtin-strlen -fno-builtin-strcat -mtune=pentium4

1
vm/Config.x86.64 Normal file
View File

@ -0,0 +1 @@
PLAF_DLL_OBJS += vm/cpu-x86.64.o

8
vm/cpu-amd64.S
View File

@ -1,8 +0,0 @@
#include "asm.h"
/* Callable from C as
void *native_stack_pointer(void) */
.globl MANGLE(native_stack_pointer)
MANGLE(native_stack_pointer):
mov %rsp,%rax
ret

20
vm/cpu-amd64.h
View File

@ -1,20 +0,0 @@
#define FACTOR_CPU_STRING "x86.64"
register CELL ds asm("r14");
register CELL rs asm("r15");
void **primitives;
INLINE void flush_icache(CELL start, CELL len) {}
void *native_stack_pointer(void);
typedef CELL F_COMPILED_FRAME;
#define PREVIOUS_FRAME(frame) (frame + 1)
#define RETURN_ADDRESS(frame) (*(frame))
INLINE void execute(CELL word)
{
F_WORD *untagged = untag_object(word);
untagged->xt(word);
}

45
vm/cpu-x86.32.S Normal file
View File

@ -0,0 +1,45 @@
#include "asm.h"
/* Note that primitive word definitions are compiled with
__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
and the callstack top is passed in EDX */
#define ARG0 %eax
#define ARG1 %edx
#define XT_REG %ecx
#define STACK_REG %esp
#define DS_REG %esi
#define CELL_SIZE 4
#define PUSH_NONVOLATILE \
push %ebx ; \
push %ebp
#define POP_NONVOLATILE \
pop %ebp ; \
pop %ebx
#define QUOT_XT_OFFSET 5
#define PROFILING_OFFSET 25
#define WORD_DEF_OFFSET 13
#define WORD_XT_OFFSET 29
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
mov 4(%esp),%ebp /* to */
mov 8(%esp),%edx /* from */
mov 12(%esp),%ecx /* length */
mov 16(%esp),%eax /* memcpy */
sub %ecx,%ebp /* compute new stack pointer */
mov %ebp,%esp
push %ecx /* pass length */
push %edx /* pass src */
push %ebp /* pass dst */
call *%eax /* call memcpy */
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
#include "cpu-x86.S"

6
vm/cpu-x86.32.h Normal file
View File

@ -0,0 +1,6 @@
#define FACTOR_CPU_STRING "x86.32"
register CELL ds asm("esi");
register CELL rs asm("edi");
#define FASTCALL __attribute__ ((regparm (2)))

37
vm/cpu-x86.64.S Normal file
View File

@ -0,0 +1,37 @@
#include "asm.h"
#define ARG0 %rdi
#define ARG1 %rsi
#define XT_REG %rcx
#define STACK_REG %rsp
#define DS_REG %r14
#define CELL_SIZE 8
#define PUSH_NONVOLATILE \
push %rbx ; \
push %rbp ; \
push %r12 ; \
push %r13 ;
#define POP_NONVOLATILE \
pop %r13 ; \
pop %r12 ; \
pop %rbp ; \
pop %rbx
#define QUOT_XT_OFFSET 13
#define PROFILING_OFFSET 53
#define WORD_DEF_OFFSET 29
#define WORD_XT_OFFSET 61
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
sub %rdx,%rdi /* compute new stack pointer */
mov %rdi,%rsp
call *%rcx /* call memcpy */
ret /* return _with new stack_ */
#include "cpu-x86.S"

6
vm/cpu-x86.64.h Normal file
View File

@ -0,0 +1,6 @@
#define FACTOR_CPU_STRING "x86.64"
register CELL ds asm("r14");
register CELL rs asm("r15");
#define FASTCALL

92
vm/cpu-x86.S
View File

@ -1,83 +1,53 @@
#include "asm.h"
/* Note that primitive word definitions are compiled with
__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
and the callstack top is passed in EDX */
/* When calling a quotation, we pass the XT in ECX */
#define JUMP_QUOT \
mov 5(%eax),%ecx ; /* Load quot-xt */ \
jmp *%ecx /* Jump to quot-xt */
mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \
jmp *XT_REG /* Jump to quot-xt */
DEF(void,c_to_factor,(CELL quot)):
push %ebp /* Save non-volatile registers */
push %ebx
DEF(FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
push ARG0 /* Save quot */
lea -8(%esp),%eax /* Save stack pointer */
push %eax /* This 16-byte aligns the stack */
lea -CELL_SIZE(STACK_REG),ARG0 /* Save stack pointer */
call MANGLE(save_callstack_bottom)
mov 16(%esp),%eax /* Pass quot as arg 1 */
mov 5(%eax),%ecx /* Pass quot-xt */
call *%ecx /* Call quot-xt */
mov (STACK_REG),ARG0 /* Pass quot as arg 1 */
mov QUOT_XT_OFFSET(ARG0),XT_REG
call *XT_REG /* Call quot-xt */
pop %eax /* Clobber */
pop %ebx /* Restore non-volatile registers */
pop %ebp
POP ARG0
POP_NONVOLATILE
ret
DEF(void,undefined,(CELL word)):
mov %esp,%ecx /* Save stack pointer before we mess with it */
sub $12,%esp /* Alignment */
mov %eax,4(%esp) /* Pass word as arg 1 (not fastcall) */
mov %ecx,8(%esp) /* Pass callstack pointer as arg 2 (not fastcall) */
jmp MANGLE(undefined_error) /* This throws an error */
DEF(FASTCALL void,undefined,(CELL word)):
mov STACK_REG,ARG1 /* Pass callstack pointer */
jmp MANGLE(undefined_error) /* This throws an error */
DEF(void,dosym,(CELL word)):
add $4,%esi /* Increment stack pointer */
mov %eax,(%esi) /* Store word on stack */
DEF(FASTCALL void,dosym,(CELL word)):
add $CELL_SIZE,DS_REG /* Increment stack pointer */
mov ARG0,(DS_REG) /* Store word on stack */
ret
/* Here we have two entry points. The first one is taken when profiling is
enabled */
DEF(void,docol_profiling,(CELL word)):
add $8,25(%eax) /* Increment profile-count slot */
DEF(void,docol,(CELL word)):
mov 13(%eax),%eax /* Load word-def slot */
DEF(FASTCALL void,docol_profiling,(CELL word)):
add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */
DEF(FASTCALL void,docol,(CELL word)):
mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */
JUMP_QUOT
/* We must pass the XT to the quotation in ECX. */
DEF(void,primitive_call,(void)):
mov (%esi),%eax /* Load quotation from data stack */
sub $4,%esi /* Pop data stack */
DEF(FASTCALL void,primitive_call,(void)):
mov (DS_REG),ARG0 /* Load quotation from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */
JUMP_QUOT
/* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the
callstack top parameter to primitives. */
DEF(void,primitive_execute,(void)):
mov (%esi),%eax /* Load word from data stack */
sub $4,%esi /* Pop data stack */
mov 29(%eax),%ecx /* Load word-xt slot */
jmp *%ecx /* Go */
DEF(FASTCALL void,primitive_execute,(void)):
mov (DS_REG),ARG0 /* Load word from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */
mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */
jmp *XT_REG /* Go */
/* We pass a function pointer to memcpy in 16(%esp) to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
mov 4(%esp),%ebp /* to */
mov 8(%esp),%edx /* from */
mov 12(%esp),%ecx /* length */
mov 16(%esp),%eax /* memcpy */
sub %ecx,%ebp /* compute new stack pointer */
mov %ebp,%esp
push %ecx /* pass length */
push %edx /* pass src */
push %ebp /* pass dst */
call *%eax /* call memcpy */
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov 4(%esp),%eax /* quot */
mov 8(%esp),%esp /* rewind_to */
DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG /* rewind_to */
JUMP_QUOT

22
vm/cpu-x86.h
View File

@ -1,10 +1,3 @@
#define FACTOR_CPU_STRING "x86.32"
register CELL ds asm("esi");
register CELL rs asm("edi");
#define FASTCALL __attribute__ ((regparm (2)))
typedef struct _F_STACK_FRAME
{
/* In compiled quotation frames, position within the array.
@ -29,14 +22,11 @@ typedef struct _F_STACK_FRAME
INLINE void flush_icache(CELL start, CELL len) {}
void c_to_factor(CELL quot);
FASTCALL void c_to_factor(CELL quot);
FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
FASTCALL void undefined(CELL word);
FASTCALL void dosym(CELL word);
FASTCALL void docol_profiling(CELL word);
FASTCALL void docol(CELL word);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
/* Defined in cpu-x86.S and only called from Factor-compiled code. They all
use funny calling convention. */
void undefined(CELL word);
void dosym(CELL word);
void docol_profiling(CELL word);
void docol(CELL word);

36
vm/image.c
View File

@ -81,19 +81,6 @@ void load_image(F_PARAMETERS *p)
userenv[IMAGE_ENV] = tag_object(from_native_string(p->image));
}
/* Compute total sum of sizes of free blocks */
void save_code_heap(FILE *file)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status == B_ALLOCATED)
fwrite(scan,scan->size,1,file);
scan = next_block(&code_heap,scan);
}
}
/* Save the current image to disk */
bool save_image(const F_CHAR *filename)
{
@ -132,7 +119,6 @@ bool save_image(const F_CHAR *filename)
fwrite(&h,sizeof(F_HEADER),1,file);
fwrite((void*)tenured->start,h.data_size,1,file);
/* save_code_heap(file); */
fwrite(first_block(&code_heap),h.code_size,1,file);
fclose(file);
@ -187,6 +173,8 @@ void fixup_alien(F_ALIEN *d)
d->expired = T;
}
F_FIXNUM delta;
void fixup_stack_frame(F_STACK_FRAME *frame)
{
code_fixup(&frame->xt);
@ -198,7 +186,21 @@ void fixup_stack_frame(F_STACK_FRAME *frame)
frame->scan = scan + frame->array;
}
/* code_fixup(&frame->return_address); */
#ifdef CALLSTACK_UP_P
F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta);
code_fixup((XT *)(next + 1));
#else
code_fixup(&frame->return_address);
#endif
}
void fixup_callstack_object(F_CALLSTACK *stack)
{
CELL top = (CELL)(stack + 1);
CELL bottom = top + untag_fixnum_fast(stack->length);
delta = (bottom - stack->bottom);
iterate_callstack_object(stack,fixup_stack_frame);
}
/* Initialize an object in a newly-loaded image */
@ -221,9 +223,7 @@ void relocate_object(CELL relocating)
fixup_alien((F_ALIEN *)relocating);
break;
case CALLSTACK_TYPE:
iterate_callstack_object(
(F_CALLSTACK *)relocating,
fixup_stack_frame);
fixup_callstack_object((F_CALLSTACK *)relocating);
break;
}
}

2
vm/layouts.h
View File

@ -88,7 +88,7 @@ INLINE void *untag_object(CELL tagged)
return (void *)UNTAG(tagged);
}
typedef void (*XT)(CELL arg);
typedef void *XT;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {

1
vm/os-freebsd-x86.32.h Normal file
View File

@ -0,0 +1 @@
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)

2
vm/os-linux-x86-32.h Normal file
View File

@ -0,0 +1,2 @@
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])

2
vm/os-linux-x86-64.h Normal file
View File

@ -0,0 +1,2 @@
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])

0
vm/os-macosx-x86.h → vm/os-macosx-x86.32.h
View File

10
vm/os-macosx.m
View File

@ -4,11 +4,11 @@
void c_to_factor_toplevel(CELL quot)
{
/* for(;;)
for(;;)
{
NS_DURING */
NS_DURING
c_to_factor(quot);
/* NS_VOIDRETURN;
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(F,(CELL)localException));
quot = userenv[COCOA_EXCEPTION_ENV];
@ -16,11 +16,11 @@ NS_HANDLER
{
/* No Cocoa exception handler was registered, so
extra/cocoa/ is not loaded. So we pass the exception
along. *
along. */
[localException raise];
}
NS_ENDHANDLER
} */
}
}
void early_init(void)

0
vm/os-openbsd-x86.h → vm/os-openbsd-x86.32.h
View File

0
vm/os-openbsd-amd64.h → vm/os-openbsd-x86.64.h
View File

20
vm/platform.h
View File

@ -13,10 +13,8 @@
#if defined(WINDOWS)
#if defined(WINCE)
#include "os-windows-ce.h"
#elif defined (__i386)
#include "os-windows-nt.h"
#else
#error "Unsupported Windows flavor"
#include "os-windows-nt.h"
#endif
#include "os-windows.h"
@ -29,7 +27,7 @@
#include "mach_signal.h"
#ifdef FACTOR_X86
#include "os-macosx-x86.h"
#include "os-macosx-x86.32.h"
#elif defined(FACTOR_PPC)
#include "os-macosx-ppc.h"
#else
@ -44,7 +42,7 @@
#include "os-unix-ucontext.h"
#if defined(FACTOR_X86)
#include "os-freebsd-x86.h"
#include "os-freebsd-x86.32.h"
#else
#error "Unsupported FreeBSD flavor"
#endif
@ -53,9 +51,9 @@
#include "os-openbsd.h"
#if defined(FACTOR_X86)
#include "os-openbsd-x86.h"
#include "os-openbsd-x86.32.h"
#elif defined(FACTOR_AMD64)
#include "os-openbsd-amd64.h"
#include "os-openbsd-x86.64.h"
#else
#error "Unsupported OpenBSD flavor"
#endif
@ -65,6 +63,7 @@
#if defined(FACTOR_X86)
#include "os-unix-ucontext.h"
#include "os-linux-x86-32.h"
#elif defined(FACTOR_PPC)
#include "os-unix-ucontext.h"
#include "os-linux-ppc.h"
@ -72,6 +71,7 @@
#include "os-linux-arm.h"
#elif defined(FACTOR_AMD64)
#include "os-unix-ucontext.h"
#include "os-linux-x86-64.h"
#else
#error "Unsupported Linux flavor"
#endif
@ -86,11 +86,13 @@
#endif
#if defined(FACTOR_X86)
#include "cpu-x86.32.h"
#include "cpu-x86.h"
#elif defined(FACTOR_AMD64)
#include "cpu-x86.64.h"
#include "cpu-x86.h"
#elif defined(FACTOR_PPC)
#include "cpu-ppc.h"
#elif defined(FACTOR_AMD64)
#include "cpu-amd64.h"
#elif defined(FACTOR_ARM)
#include "cpu-arm.h"
#else

2
vm/run.c
View File

@ -199,7 +199,7 @@ void not_implemented_error(void)
}
/* This function is called from the undefined function in cpu_*.S */
void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
{
stack_chain->callstack_top = callstack_top;
general_error(ERROR_UNDEFINED_WORD,word,F,NULL);

3
vm/run.h
View File

@ -196,7 +196,8 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
DECLARE_PRIMITIVE(throw);

6
vm/stack.c
View File

@ -19,7 +19,7 @@ void fix_stacks(void)
}
/* called before entry into Factor code. */
void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
@ -111,7 +111,7 @@ void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator
while(ITERATING_P)
{
F_STACK_FRAME *next = (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta);
F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta);
iterator(frame);
frame = next;
}
@ -344,7 +344,7 @@ static F_FIXNUM delta;
void adjust_stack_frame(F_STACK_FRAME *frame)
{
FRAME_SUCCESSOR(frame) = (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta);
FRAME_SUCCESSOR(frame) = REBASE_FRAME_SUCCESSOR(frame,delta);
}
void adjust_callstack(F_CALLSTACK *stack, CELL bottom)

4
vm/stack.h
View File

@ -48,7 +48,7 @@ CELL ds_size, rs_size;
void reset_datastack(void);
void reset_retainstack(void);
void fix_stacks(void);
void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
DLLEXPORT void save_stacks(void);
DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void);
@ -56,6 +56,8 @@ void init_stacks(CELL ds_size, CELL rs_size);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
#define REBASE_FRAME_SUCCESSOR(frame,delta) (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta)
typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator);