[ "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 ;
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
[
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
! 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
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 ] [ ] ]
( 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 -- )
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 * ;
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 ;
: 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 ;
: 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 ;
: 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 ;
! 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 ;
: 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 ;
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 ;
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> ;
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
#! 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: %unbox generate-node
- #! C functions return integers in EAX.
- UNBOX
- #! Push integer on C stack.
- EAX PUSH ;
+M: int-regs reg-size drop cell ;
+M: int-regs push-reg drop 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: float-regs reg-size drop 4 ;
+M: float-regs push-reg
+ ESP swap reg-size 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 ;
+M: double-regs reg-size drop 8 ;
+M: double-regs push-reg
+ ESP swap reg-size 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 ;
+M: %unbox generate-node
+ 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 ;
: >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 ;
[ "\0\0\0\0\u000f\u000e\r\u000c" ]
[
- [ image-magic write-be8 ] with-string
+ [ image-magic 8 >be write ] with-string
] unit-test
[
"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 ;
! 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
: 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 ;
: 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 ;
#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;
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);
projects / factor.git / commitdiff