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

various cleanups, and a new register class concept in preparation for float parameters in PowerPC FFI

cvs
Slava Pestov 2005-06-14 09:01:07 +00:00
parent d59988b60d
commit 69334b2043
14 changed files with 139 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
library/alien/c-types.factor
View File

@ -10,9 +10,8 @@ sequences strings words ;
[ "No setter" throw ] "setter" set
[ "No getter" throw ] "getter" set
"no boxer" "boxer" set
\ %box "box-op" set
"no unboxer" "unboxer" set
\ %unbox "unbox-op" set
<< int-regs f >> "reg-class" set
0 "width" set
] extend ;
@ -214,9 +213,8 @@ global [ c-types nest drop ] bind
cell "width" set
cell "align" set
"box_float" "boxer" set
\ %box-float "box-op" set
"unbox_float" "unboxer" set
\ %unbox-float "unbox-op" set
<< float-regs f >> "reg-class" set
] "float" define-primitive-type
[
@ -225,9 +223,8 @@ global [ c-types nest drop ] bind
cell 2 * "width" set
cell 2 * "align" set
"box_double" "boxer" set
\ %box-double "box-op" set
"unbox_double" "unboxer" set
\ %unbox-double "unbox-op" set
<< double-regs f >> "reg-class" set
] "double" define-primitive-type
! FIXME for 64-bit platforms

36
library/alien/compiler.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-frontend compiler-backend
errors generic inference kernel lists math namespaces sequences
stdio strings unparser words ;
USING: assembler compiler compiler-backend compiler-frontend
errors generic hashtables inference kernel lists math namespaces
sequences stdio strings unparser words ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
@ -83,35 +83,33 @@ C: alien-node make-node ;
0 swap [ c-size cell align + ] each ;
: unbox-parameter ( n parameter -- )
c-type [ "unboxer" get cons "unbox-op" get ] bind execute , ;
c-type [ "unboxer" get "reg-class" get ] bind %unbox , ;
: linearize-parameters ( node -- count )
: load-parameter ( n parameter -- )
c-type "reg-class" swap hash %parameter , ;
: linearize-parameters ( parameters -- )
#! Generate code for boxing a list of C types, then generate
#! code for moving these parameters to register on
#! architectures where parameters are passed in registers
#! (PowerPC).
#!
#! Return amount stack must be unwound by.
parameters
dup stack-space
dup %parameters , >r
dup dup length swap [
>r 1 - dup r> unbox-parameter
] each drop
length [ %parameter ] project % r> ;
dup stack-space %parameters ,
[ length ] keep 2dup
[ >r 1 - dup r> unbox-parameter ] each drop
[ >r 1 - dup r> load-parameter ] each drop ;
: linearize-return ( return -- )
alien-node-return dup "void" = [
drop
] [
c-type [ "boxer" get "box-op" get ] bind execute ,
c-type [ "boxer" get "reg-class" get ] bind %box ,
] ifte ;
M: alien-node linearize-node* ( node -- )
dup linearize-parameters >r
dup node-param %alien-invoke ,
dup node-param cdr library-abi "stdcall" =
r> swap [ drop ] [ %cleanup , ] ifte
dup parameters linearize-parameters
dup node-param dup uncons %alien-invoke ,
cdr library-abi "stdcall" =
[ dup parameters stack-space %cleanup , ] unless
linearize-return ;
\ alien-invoke [ [ string object string general-list ] [ ] ]

14
library/bootstrap/image.factor
View File

@ -301,18 +301,10 @@ M: hashtable ' ( hashtable -- pointer )
( Image output )
: (write-image) ( image -- )
"64-bits" get [
"big-endian" get [
[ write-be8 ] each
] [
[ write-le8 ] each
] ifte
"64-bits" get 8 4 ? swap "big-endian" get [
[ swap >be write ] each-with
] [
"big-endian" get [
[ write-be4 ] each
] [
[ write-le4 ] each
] ifte
[ swap >le write ] each-with
] ifte ;
: write-image ( image file -- )

19
library/compiler/ppc/alien.factor
View File

@ -5,7 +5,7 @@ USING: alien compiler compiler-backend inference kernel
kernel-internals lists math memory namespaces words ;
M: %alien-invoke generate-node ( vop -- )
vop-in-1 uncons load-library compile-c-call ;
dup vop-in-1 swap vop-in-2 load-library compile-c-call ;
: stack-size 8 + 16 align ;
: stack@ 3 + cell * ;
@ -13,8 +13,23 @@ M: %alien-invoke generate-node ( vop -- )
M: %parameters generate-node ( vop -- )
vop-in-1 dup 0 = [ drop ] [ stack-size 1 1 rot SUBI ] ifte ;
GENERIC: store-insn
GENERIC: return-reg
M: int-regs store-insn drop STW ;
M: int-regs return-reg drop 3 ;
M: float-regs store-insn drop STFS ;
M: float-regs return-reg drop 1 ;
M: double-regs store-insn drop STFD ;
M: double-regs return-reg drop 1 ;
M: %unbox generate-node ( vop -- )
vop-in-1 uncons f compile-c-call 3 1 rot stack@ STW ;
[ vop-in-2 f compile-c-call ] keep
[ vop-in-3 return-reg 1 ] keep
[ vop-in-1 stack@ ] keep
vop-in-3 store-insn ;
M: %parameter generate-node ( vop -- )
vop-in-1 dup 3 + 1 rot stack@ LWZ ;

114
library/compiler/ppc/assembler.factor
View File

@ -51,125 +51,92 @@ USING: compiler errors kernel math memory words ;
: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
: (ADD) 266 xo-form 31 insn ;
: ADD 0 0 (ADD) ;
: ADD. 0 1 (ADD) ;
: ADDO 1 0 (ADD) ;
: ADDO. 1 1 (ADD) ;
: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ;
: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
: (ADDC) 10 xo-form 31 insn ;
: ADDC 0 0 (ADDC) ;
: ADDC. 0 1 (ADDC) ;
: ADDCO 1 0 (ADDC) ;
: ADDCO. 1 1 (ADDC) ;
: ADDC 0 0 (ADDC) ; : ADDC. 0 1 (ADDC) ;
: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
: (ADDE) 138 xo-form 31 insn ;
: ADDE 0 0 (ADDE) ;
: ADDE. 0 1 (ADDE) ;
: ADDEO 1 0 (ADDE) ;
: ADDEO. 1 1 (ADDE) ;
: ADDE 0 0 (ADDE) ; : ADDE. 0 1 (ADDE) ;
: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
: ANDI d-form 28 insn ;
: ANDIS d-form 29 insn ;
: (AND) 28 x-form 31 insn ;
: AND 0 (AND) ;
: AND. 0 (AND) ;
: AND 0 (AND) ; : AND. 0 (AND) ;
: (DIVW) 491 xo-form 31 insn ;
: DIVW 0 0 (DIVW) ;
: DIVW. 0 1 (DIVW) ;
: DIVWO 1 0 (DIVW) ;
: DIVWO 1 1 (DIVW) ;
: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ;
: DIVWO 1 0 (DIVW) ; : DIVWO 1 1 (DIVW) ;
: (DIVWU) 459 xo-form 31 insn ;
: DIVWU 0 0 (DIVWU) ;
: DIVWU. 0 1 (DIVWU) ;
: DIVWUO 1 0 (DIVWU) ;
: DIVWUO. 1 1 (DIVWU) ;
: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ;
: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
: (EQV) 284 x-form 31 insn ;
: EQV 0 (EQV) ;
: EQV. 1 (EQV) ;
: EQV 0 (EQV) ; : EQV. 1 (EQV) ;
: (NAND) 476 x-form 31 insn ;
: NAND 0 (NAND) ;
: NAND. 1 (NAND) ;
: NAND 0 (NAND) ; : NAND. 1 (NAND) ;
: (NOR) 124 x-form 31 insn ;
: NOR 0 (NOR) ;
: NOR. 1 (NOR) ;
: NOR 0 (NOR) ; : NOR. 1 (NOR) ;
: NOT dup NOR ;
: NOT. dup NOR. ;
: NOT dup NOR ; : NOT. dup NOR. ;
: ORI d-form 24 insn ;
: ORIS d-form 25 insn ;
: ORI d-form 24 insn ; : ORIS d-form 25 insn ;
: (OR) 444 x-form 31 insn ;
: OR 0 (OR) ;
: OR. 1 (OR) ;
: OR 0 (OR) ; : OR. 1 (OR) ;
: (ORC) 412 x-form 31 insn ;
: ORC 0 (ORC) ;
: ORC. 1 (ORC) ;
: ORC 0 (ORC) ; : ORC. 1 (ORC) ;
: MR dup OR ;
: MR. dup OR. ;
: MR dup OR ; : MR. dup OR. ;
: (MULHW) 75 xo-form 31 insn ;
: MULHW 0 0 (MULHW) ;
: MULHW. 0 1 (MULHW) ;
: MULHW 0 0 (MULHW) ; : MULHW. 0 1 (MULHW) ;
: MULLI d-form 7 insn ;
: (MULHWU) 11 xo-form 31 insn ;
: MULHWU 0 0 (MULHWU) ;
: MULHWU. 0 1 (MULHWU) ;
: MULHWU 0 0 (MULHWU) ; : MULHWU. 0 1 (MULHWU) ;
: (MULLW) 235 xo-form 31 insn ;
: MULLW 0 0 (MULLW) ;
: MULLW. 0 1 (MULLW) ;
: MULLWO 1 0 (MULLW) ;
: MULLWO. 1 1 (MULLW) ;
: MULLW 0 0 (MULLW) ; : MULLW. 0 1 (MULLW) ;
: MULLWO 1 0 (MULLW) ; : MULLWO. 1 1 (MULLW) ;
: (SLW) 24 x-form 31 insn ;
: SLW 0 (SLW) ;
: SLW. 1 (SLW) ;
: SLW 0 (SLW) ; : SLW. 1 (SLW) ;
: (SRAW) 792 x-form 31 insn ;
: SRAW 0 (SRAW) ;
: SRAW. 1 (SRAW) ;
: SRAW 0 (SRAW) ; : SRAW. 1 (SRAW) ;
: (SRW) 536 x-form 31 insn ;
: SRW 0 (SRW) ;
: SRW. 1 (SRW) ;
: SRW 0 (SRW) ; : SRW. 1 (SRW) ;
: SRAWI 0 824 x-form 31 insn ;
: (SUBF) 40 xo-form 31 insn ;
: SUBF 0 0 (SUBF) ;
: SUBF. 0 1 (SUBF) ;
: SUBFO 1 0 (SUBF) ;
: SUBFO. 1 1 (SUBF) ;
: SUBF 0 0 (SUBF) ; : SUBF. 0 1 (SUBF) ;
: SUBFO 1 0 (SUBF) ; : SUBFO. 1 1 (SUBF) ;
: (SUBFC) 8 xo-form 31 insn ;
: SUBFC 0 0 (SUBFC) ;
: SUBFC. 0 1 (SUBFC) ;
: SUBFCO 1 0 (SUBFC) ;
: SUBFCO. 1 1 (SUBFC) ;
: SUBFC 0 0 (SUBFC) ; : SUBFC. 0 1 (SUBFC) ;
: SUBFCO 1 0 (SUBFC) ; : SUBFCO. 1 1 (SUBFC) ;
: (SUBFE) 136 xo-form 31 insn ;
: SUBFE 0 0 (SUBFE) ;
: SUBFE. 0 1 (SUBFE) ;
: SUBFEO 1 0 (SUBFE) ;
: SUBFEO. 1 1 (SUBFE) ;
: SUBFE 0 0 (SUBFE) ; : SUBFE. 0 1 (SUBFE) ;
: SUBFEO 1 0 (SUBFE) ; : SUBFEO. 1 1 (SUBFE) ;
: XORI d-form 26 insn ;
: XORIS d-form 27 insn ;
: (XOR) 316 x-form 31 insn ;
: XOR 0 (XOR) ;
: XOR. 1 (XOR) ;
: XOR 0 (XOR) ; : XOR. 1 (XOR) ;
: CMPI d-form 11 insn ;
: CMPLI d-form 10 insn ;
@ -178,11 +145,9 @@ USING: compiler errors kernel math memory words ;
: CMPL 0 32 x-form 31 insn ;
: (RLWINM) m-form 21 insn ;
: RLWINM 0 (RLWINM) ;
: RLWINM. 1 (RLWINM) ;
: RLWINM 0 (RLWINM) ; : RLWINM. 1 (RLWINM) ;
: SLWI 0 31 pick - RLWINM ;
: SLWI. 0 31 pick - RLWINM. ;
: SLWI 0 31 pick - RLWINM ; : SLWI. 0 31 pick - RLWINM. ;
: LBZ d-form 34 insn ; : LBZU d-form 35 insn ;
: LHA d-form 42 insn ; : LHAU d-form 43 insn ;
@ -226,3 +191,12 @@ M: word BC >r 0 BC r> relative-14 ;
: LOAD ( n r -- )
#! PowerPC cannot load a 32 bit literal in one instruction.
>r dup dup HEX: ffff bitand = [ r> LI ] [ r> LOAD32 ] ifte ;
! Floating point
: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
: FMR 0 (FMR) ; : FMR. 1 (FMR) ;
: LFS d-form 48 insn ; : LFSU d-form 49 insn ;
: LFD d-form 50 insn ; : LFDU d-form 51 insn ;
: STFS d-form 52 insn ; : STFSU d-form 53 insn ;
: STFD d-form 54 insn ; : STFDU d-form 55 insn ;

34
library/compiler/vops.factor
View File

@ -21,6 +21,11 @@ parser sequences words ;
! A virtual register
TUPLE: vreg n ;
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs ;
TUPLE: double-regs ;
! A virtual operation
TUPLE: vop inputs outputs label ;
: vop-in-1 ( vop -- input ) vop-inputs first ;
@ -47,6 +52,7 @@ M: vop calls-label? vop-label = ;
: dest-vop ( dest) unit dup f ;
: src/dest-vop ( src dest) >r unit r> unit f ;
: 2-in-vop ( in1 in2) 2list f f ;
: 3-in-vop ( in1 in2 in3) 3list f f ;
: 2-in/label-vop ( in1 in2 label) >r 2list f r> ;
: 2-vop ( in dest) [ 2list ] keep unit f ;
: 3-vop ( in1 in2 dest) >r 2list r> unit f ;
@ -334,7 +340,7 @@ C: %parameters make-vop ;
TUPLE: %parameter ;
C: %parameter make-vop ;
: %parameter ( n -- vop ) src-vop <%parameter> ;
: %parameter ( n reg-class -- vop ) 2-in-vop <%parameter> ;
TUPLE: %cleanup ;
C: %cleanup make-vop ;
@ -342,32 +348,12 @@ C: %cleanup make-vop ;
TUPLE: %unbox ;
C: %unbox make-vop ;
: %unbox ( [[ n func ]] -- vop ) src-vop <%unbox> ;
TUPLE: %unbox-float ;
C: %unbox-float make-vop ;
: %unbox-float ( [[ n func ]] -- vop ) src-vop <%unbox-float> ;
TUPLE: %unbox-double ;
C: %unbox-double make-vop ;
: %unbox-double ( [[ n func ]] -- vop ) src-vop <%unbox-double> ;
: %unbox ( n func reg-class -- vop ) 3-in-vop <%unbox> ;
TUPLE: %box ;
C: %box make-vop ;
: %box ( func -- vop ) src-vop <%box> ;
TUPLE: %box-float ;
C: %box-float make-vop ;
: %box-float ( func -- vop ) src-vop <%box-float> ;
TUPLE: %box-double ;
C: %box-double make-vop ;
: %box-double ( [[ n func ]] -- vop ) src-vop <%box-double> ;
: %box ( func reg-class -- vop ) 2-in-vop <%box> ;
TUPLE: %alien-invoke ;
C: %alien-invoke make-vop ;
: %alien-invoke ( func -- vop ) src-vop <%alien-invoke> ;
TUPLE: %alien-global ;
C: %alien-global make-vop ;
: %alien-global ( global -- vop ) src-vop <%alien-global> ;
: %alien-invoke ( func lib -- vop ) 2-in-vop <%alien-invoke> ;

72
library/compiler/x86/alien.factor
View File

@ -6,11 +6,7 @@ kernel-internals lists math memory namespaces words ;
M: %alien-invoke generate-node
#! call a C function.
vop-in-1 uncons load-library compile-c-call ;
M: %alien-global generate-node
vop-in-1 uncons load-library
2dup dlsym EAX swap unit MOV 0 0 rel-dlsym ;
dup vop-in-1 swap vop-in-2 load-library compile-c-call ;
M: %parameters generate-node
#! x86 does not pass parameters in registers
@ -20,59 +16,27 @@ M: %parameter generate-node
#! x86 does not pass parameters in registers
drop ;
: UNBOX ( vop -- )
#! An unboxer function takes a value from the data stack and
#! converts it into a C value.
vop-in-1 cdr f compile-c-call ;
GENERIC: reg-size ( reg-class -- n )
GENERIC: push-reg ( reg-class -- )
M: int-regs reg-size drop cell ;
M: int-regs push-reg drop EAX PUSH ;
M: float-regs reg-size drop 4 ;
M: float-regs push-reg
ESP swap reg-size SUB [ ESP ] FSTPS ;
M: double-regs reg-size drop 8 ;
M: double-regs push-reg
ESP swap reg-size SUB [ ESP ] FSTPL ;
M: %unbox generate-node
#! C functions return integers in EAX.
UNBOX
#! Push integer on C stack.
EAX PUSH ;
M: %unbox-float generate-node
#! C functions return floats on the FP stack.
UNBOX
#! Push float on C stack.
ESP 4 SUB
[ ESP ] FSTPS ;
M: %unbox-double generate-node
#! C functions return doubles on the FP stack.
UNBOX
#! Push double on C stack.
ESP 8 SUB
[ ESP ] FSTPL ;
: BOX ( vop -- )
#! A boxer function takes a C value as a parameter and
#! converts into a Factor value, and pushes it on the data
#! stack.
vop-in-1 f compile-c-call ;
dup vop-in-2 f compile-c-call vop-in-3 push-reg ;
M: %box generate-node
#! C functions return integers in EAX.
EAX PUSH
#! Push integer on data stack.
BOX
ESP 4 ADD ;
M: %box-float generate-node
#! C functions return floats on the FP stack.
ESP 4 SUB
[ ESP ] FSTPS
#! Push float on data stack.
BOX
ESP 4 ADD ;
M: %box-double generate-node
#! C functions return doubles on the FP stack.
ESP 8 SUB
[ ESP ] FSTPL
#! Push double on data stack.
BOX
ESP 8 ADD ;
dup vop-in-2 push-reg
dup vop-in-1 f compile-c-call
vop-in-2 ESP swap reg-size ADD ;
M: %cleanup generate-node
vop-in-1 dup 0 = [ drop ] [ ESP swap ADD ] ifte ;

8
library/io/binary.factor
View File

@ -10,11 +10,3 @@ USING: kernel lists math sequences strings ;
: >le ( x n -- string ) [ nth-byte ] project-with >string ;
: >be ( x n -- string ) >le reverse ;
: read-le2 ( -n) 2 read le> ; : read-be2 ( -n) 2 read be> ;
: read-le4 ( -n) 4 read le> ; : read-be4 ( -n) 4 read be> ;
: read-le8 ( -n) 8 read le> ; : read-be8 ( -n) 8 read be> ;
: write-le2 ( n-) 2 >le write ; : write-be2 ( n-) 2 >be write ;
: write-le4 ( n-) 4 >le write ; : write-be4 ( n-) 4 >be write ;
: write-le8 ( n-) 8 >le write ; : write-be8 ( n-) 8 >be write ;

2
library/test/image.factor
View File

@ -23,7 +23,7 @@ USE: math
[ "\0\0\0\0\u000f\u000e\r\u000c" ]
[
[ image-magic write-be8 ] with-string
[ image-magic 8 >be write ] with-string
] unit-test
[

3
library/test/test.factor
View File

@ -87,7 +87,8 @@ SYMBOL: failures
"httpd/url-encoding" "httpd/html" "httpd/httpd"
"httpd/http-client"
"crashes" "sbuf" "threads" "parsing-word"
"inference" "interpreter" "alien"
"inference" "interpreter"
"alien"
"line-editor" "gadgets" "memory" "redefine"
"annotate" "sequences" "binary"
] run-tests ;

12
library/tools/jedit-wire.factor
View File

@ -13,10 +13,11 @@ prettyprint sequences stdio streams strings words ;
! jEdit sends a packet with code to eval, it receives the output
! captured with with-string.
: write-packet ( string -- )
dup length write-be4 write flush ;
: write-len ( seq -- ) length 4 >be write ;
: read-packet ( -- string ) read-be4 read ;
: write-packet ( string -- ) dup write-len write flush ;
: read-packet ( -- string ) 4 read be> read ;
: wire-server ( -- )
#! Repeatedly read jEdit requests and execute them. Return
@ -39,13 +40,12 @@ prettyprint sequences stdio streams strings words ;
: jedit-write-attr ( str style -- )
CHAR: w write
[ swap . . ] with-string
dup length write-be4
write ;
dup write-len write ;
TUPLE: jedit-stream ;
M: jedit-stream stream-readln ( stream -- str )
[ CHAR: r write flush read-be4 read ] with-wrapper ;
[ CHAR: r write flush 4 read be> read ] with-wrapper ;
M: jedit-stream stream-write-attr ( str style stream -- )
[ jedit-write-attr ] with-wrapper ;

4
library/tools/jedit.factor
View File

@ -25,8 +25,8 @@ streams strings unparser words ;
: send-jedit-request ( request -- )
jedit-server-info swap "localhost" swap <client> [
write-be4
dup length write-be2
4 >be write
dup length 2 >be write
write flush
] with-stream ;

15
native/float.c
View File

@ -1,5 +1,20 @@
#include "factor.h"
float f_test(void)
{
return 1.0f;
}
double d_test(void)
{
return 1.0;
}
float in_f_test(float x, float y)
{
return x + y;
}
double to_float(CELL tagged)
{
F_RATIO* r;

1
native/unix/signal.c
View File

@ -52,6 +52,7 @@ void init_signals(void)
sigaction(SIGABRT,&custom_sigaction,NULL);
sigaction(SIGFPE,&custom_sigaction,NULL);
sigaction(SIGBUS,&custom_sigaction,NULL);
sigaction(SIGILL,&custom_sigaction,NULL);
sigaction(SIGSEGV,&custom_sigaction,NULL);
sigaction(SIGPIPE,&ign_sigaction,NULL);
sigaction(SIGPROF,&profiling_sigaction,NULL);