Compare commits

..

1 Commits

Author SHA1 Message Date
Doug Coleman c318ac10d0 io.files.info: Fix linux file-system-info recursion 2020-01-05 13:22:01 -06:00
986 changed files with 4658 additions and 14163 deletions

1
.gitattributes vendored
View File

@ -1,3 +1,2 @@
*.factor text eol=lf *.factor text eol=lf
*.html text eol=lf *.html text eol=lf
misc/vim/*/*/generated.vim linguist-generated

View File

@ -1,4 +1,4 @@
Copyright (c) 2020, Slava Pestov, et al. Copyright (c) 2019, Slava Pestov, et al.
All rights reserved. All rights reserved.
Redistribution and use in source and binary forms, with or without Redistribution and use in source and binary forms, with or without

View File

@ -58,13 +58,6 @@ CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
SUBSYSTEM_COM_FLAGS = console SUBSYSTEM_COM_FLAGS = console
SUBSYSTEM_EXE_FLAGS = windows SUBSYSTEM_EXE_FLAGS = windows
!ELSE
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
SUBSYSTEM_COM_FLAGS = console
SUBSYSTEM_EXE_FLAGS = windows
!ENDIF !ENDIF
!IF DEFINED(DEBUG) !IF DEFINED(DEBUG)
@ -150,16 +143,6 @@ factor.com: $(EXE_OBJS) $(DLL_OBJS)
factor.exe: $(EXE_OBJS) $(DLL_OBJS) factor.exe: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:$(SUBSYSTEM_EXE_FLAGS) $(EXE_OBJS) $(DLL_OBJS) link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:$(SUBSYSTEM_EXE_FLAGS) $(EXE_OBJS) $(DLL_OBJS)
# If we compile factor.exe, run mt.exe, and run factor.exe,
# then Windows caches the manifest. Even on a recompile without applying
# the mt.exe tool, if the factor.exe.manifest file is present, the manifest
# is applied. To avoid this, we delete the .manifest file on clean
# and copy it from a reference file on compilation and mt.exe.
#
factor.exe.manifest: factor.exe
copy factor.exe.manifest.in factor.exe.manifest
mt -manifest factor.exe.manifest -outputresource:"factor.exe;#1"
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
!ENDIF !ENDIF
@ -191,15 +174,12 @@ clean:
if exist factor.lib del factor.lib if exist factor.lib del factor.lib
if exist factor.com del factor.com if exist factor.com del factor.com
if exist factor.exe del factor.exe if exist factor.exe del factor.exe
if exist factor.exe.manifest del factor.exe.manifest
if exist factor.exp del factor.exp
if exist factor.dll del factor.dll if exist factor.dll del factor.dll
if exist factor.dll.lib del factor.dll.lib if exist factor.dll.lib del factor.dll.lib
if exist factor.dll.exp del factor.dll.exp
if exist libfactor-ffi-test.dll del libfactor-ffi-test.dll if exist libfactor-ffi-test.dll del libfactor-ffi-test.dll
if exist libfactor-ffi-test.exp del libfactor-ffi-test.exp if exist libfactor-ffi-test.exp del libfactor-ffi-test.exp
if exist libfactor-ffi-test.lib del libfactor-ffi-test.lib if exist libfactor-ffi-test.lib del libfactor-ffi-test.lib
.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean factor.exe.manifest .PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean
.SUFFIXES: .rs .SUFFIXES: .rs

View File

@ -28,7 +28,7 @@ a boot image stored on factorcode.org.
To check out Factor: To check out Factor:
* `git clone git://github.com/factor/factor.git` * `git clone git://factorcode.org/git/factor.git`
* `cd factor` * `cd factor`
To build the latest complete Factor system from git, either use the To build the latest complete Factor system from git, either use the
@ -38,7 +38,7 @@ build script:
* Windows: `build.cmd` * Windows: `build.cmd`
or download the correct boot image for your system from or download the correct boot image for your system from
http://downloads.factorcode.org/images/master/, put it in the `factor` http://downloads.factorcode.org/images/master/, put it in the factor
directory and run: directory and run:
* Unix: `make` and then `./factor -i=boot.unix-x86.64.image` * Unix: `make` and then `./factor -i=boot.unix-x86.64.image`
@ -127,25 +127,6 @@ The Factor source tree is organized as follows:
* `misc/` - editor modes, icons, etc * `misc/` - editor modes, icons, etc
* `unmaintained/` - now at [factor-unmaintained](https://github.com/factor/factor-unmaintained) * `unmaintained/` - now at [factor-unmaintained](https://github.com/factor/factor-unmaintained)
## Source History
During Factor's lifetime, sourcecode has lived in many repositories. Unfortunately, the first import in Git did not keep history. History has been partially recreated from what could be salvaged. Due to the nature of Git, it's only possible to add history without disturbing upstream work, by using replace objects. These need to be manually fetched, or need to be explicitly added to your git remote configuration.
Use:
`git fetch origin 'refs/replace/*:refs/replace/*'`
or add the following line to your configuration file
```
[remote "origin"]
url = ...
fetch = +refs/heads/*:refs/remotes/origin/*
...
fetch = +refs/replace/*:refs/replace/*
```
Then subsequent fetches will automatically update any replace objects.
## Community ## Community
Factor developers meet in the `#concatenative` channel on Factor developers meet in the `#concatenative` channel on

View File

@ -105,7 +105,7 @@ $nl
ARTICLE: "c-types.primitives" "Primitive C types" ARTICLE: "c-types.primitives" "Primitive C types"
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:" "The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
{ $table { $table
{ { $strong "C type" } { $strong "Notes" } } { "C type" "Notes" }
{ { $link char } "always 1 byte" } { { $link char } "always 1 byte" }
{ { $link uchar } { } } { { $link uchar } { } }
{ { $link short } "always 2 bytes" } { { $link short } "always 2 bytes" }

View File

@ -41,8 +41,8 @@ HELP: memory>byte-array
HELP: cast-array HELP: cast-array
{ $values { "byte-array" byte-array } { "c-type" "a C type" } { "array" "a specialized array" } } { $values { "byte-array" byte-array } { "c-type" "a C type" } { "array" "a specialized array" } }
{ $description "Converts a " { $link byte-array } " into a specialized array by interpreting the bytes in it as machine-specific values. Code using this word is unportable." } { $description "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable." }
{ $notes "The appropriate specialized array vocabulary must be loaded, otherwise an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: malloc-array HELP: malloc-array
@ -257,4 +257,4 @@ ARTICLE: "c-out-params" "Output parameters in C"
{ $code { $code
"1234 { c-string } [ do_frob ] with-out-parameters" "1234 { c-string } [ do_frob ] with-out-parameters"
} }
"which would put the function's return value and error string on the stack." ; "which would put the functions return value and error string on the stack." ;

View File

@ -1,4 +1,5 @@
USING: alien.libraries.finder sequences tools.test ; USING: alien.libraries.finder sequences tools.test ;
IN: alien.libraries.finder.linux.tests
{ t } [ "libm.so" "m" find-library subseq? ] unit-test { t } [ "libm.so" "m" find-library subseq? ] unit-test
{ t } [ "libc.so" "c" find-library subseq? ] unit-test { t } [ "libc.so" "c" find-library subseq? ] unit-test

View File

@ -44,4 +44,4 @@ PRIVATE>
M: linux find-library* M: linux find-library*
"lib" prepend load-ldconfig-cache "lib" prepend load-ldconfig-cache
[ ldconfig-matches? ] with find nip ?last ; [ ldconfig-matches? ] with find nip ?first ;

View File

@ -1,6 +1,9 @@
USING: alien.libraries.finder alien.libraries.finder.macosx
USING: alien.libraries.finder
alien.libraries.finder.macosx.private sequences tools.test ; alien.libraries.finder.macosx.private sequences tools.test ;
IN: alien.libraries.finder.macosx
{ {
{ {
f f

View File

@ -1,3 +0,0 @@
USING: alien.libraries.finder sequences tools.test ;
{ t } [ "kernel32.dll" "kernel32" find-library subseq? ] unit-test

View File

@ -1,9 +1,8 @@
USING: alien.libraries io.pathnames system windows.errors USING: alien.libraries io.pathnames system windows.errors ;
windows.kernel32 ;
IN: alien.libraries.windows IN: alien.libraries.windows
M: windows >deployed-library-path M: windows >deployed-library-path
file-name ; file-name ;
M: windows dlerror ( -- message ) M: windows dlerror ( -- message )
GetLastError n>win32-error-string ; win32-error-string ;

View File

@ -1,2 +1 @@
algorithms algorithms
collections

View File

@ -166,10 +166,10 @@ ERROR: not-enough-bits n bit-reader ;
bs bytes>> subseq endian> execute( seq -- x ) bs bytes>> subseq endian> execute( seq -- x )
n bs subseq-endian execute( bignum n bs -- bits ) ; n bs subseq-endian execute( bignum n bs -- bits ) ;
M: lsb0-bit-reader peek M: lsb0-bit-reader peek ( n bs -- bits )
\ le> \ subseq>bits-le (peek) ; \ le> \ subseq>bits-le (peek) ;
M: msb0-bit-reader peek M: msb0-bit-reader peek ( n bs -- bits )
\ be> \ subseq>bits-be (peek) ; \ be> \ subseq>bits-be (peek) ;
:: bit-writer-bytes ( writer -- bytes ) :: bit-writer-bytes ( writer -- bytes )

View File

@ -46,7 +46,7 @@ HELP: sub-primitives
ARTICLE: "bootstrap.image" "Bootstrapping new images" ARTICLE: "bootstrap.image" "Bootstrapping new images"
"A new image can be built from source; this is known as " { $emphasis "bootstrap" } ". Bootstrap is a two-step process. The first stage is the creation of a bootstrap image from a running Factor instance:" "A new image can be built from source; this is known as " { $emphasis "bootstrap" } ". Bootstrap is a two-step process. The first stage is the creation of a bootstrap image from a running Factor instance:"
{ $subsections make-image make-my-image } { $subsections make-image }
"The second bootstrapping stage is initiated by running the resulting bootstrap image:" "The second bootstrapping stage is initiated by running the resulting bootstrap image:"
{ $code "./factor -i=boot.x86.32.image" } { $code "./factor -i=boot.x86.32.image" }
"This stage loads additional code, compiles all words, and creates a final " { $snippet "factor.image" } "." "This stage loads additional code, compiles all words, and creates a final " { $snippet "factor.image" } "."

View File

@ -1,15 +1,15 @@
! Copyright (C) 2004, 2011 Slava Pestov. ! Copyright (C) 2004, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays classes USING: accessors arrays assocs byte-arrays classes classes.builtin
classes.builtin classes.private classes.tuple classes.private classes.tuple classes.tuple.private combinators
classes.tuple.private combinators combinators.short-circuit combinators.short-circuit combinators.smart
combinators.smart command-line compiler.codegen.relocation compiler.codegen.relocation compiler.units fry generic
compiler.units fry generic generic.single.private grouping generic.single.private grouping hashtables hashtables.private io
hashtables hashtables.private io io.binary io.encodings.binary io.binary io.encodings.binary io.files io.pathnames kernel
io.files io.pathnames kernel kernel.private layouts locals make kernel.private layouts locals make math math.order namespaces
math math.order namespaces namespaces.private parser namespaces.private parser parser.notes prettyprint quotations
parser.notes prettyprint quotations sequences sequences.private sequences sequences.private source-files strings system vectors
source-files strings system vectors vocabs words ; vocabs words ;
IN: bootstrap.image IN: bootstrap.image
: arch-name ( os cpu -- arch ) : arch-name ( os cpu -- arch )
@ -540,8 +540,3 @@ PRIVATE>
: make-my-image ( -- ) : make-my-image ( -- )
my-arch-name make-image ; my-arch-name make-image ;
: make-image-main ( -- )
command-line get [ make-my-image ] [ [ make-image ] each ] if-empty ;
MAIN: make-image-main

View File

@ -778,8 +778,8 @@ CONSTANT: all-primitives {
{ {
"tools.profiler.sampling.private" "tools.profiler.sampling.private"
{ {
{ "set-profiling" ( n -- ) "set_profiling" { object } { } f } { "profiling" ( n -- ) "sampling_profiler" { object } { } f }
{ "get-samples" ( -- samples/f ) "get_samples" { } { object } f } { "(get-samples)" ( -- samples/f ) "get_samples" { } { object } f }
} }
} }
{ {

View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2015 Doug Coleman. ! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image checksums checksums.openssl fry io USING: bootstrap.image checksums checksums.openssl cli.git fry
io.directories io.encodings.ascii io.encodings.utf8 io.files io io.directories io.encodings.ascii io.encodings.utf8 io.files
io.files.temp io.files.unique io.launcher io.pathnames kernel io.files.temp io.files.unique io.launcher io.pathnames kernel
make math.parser namespaces sequences splitting system unicode ; make math.parser namespaces sequences splitting system ;
IN: bootstrap.image.upload IN: bootstrap.image.upload
SYMBOL: upload-images-destination SYMBOL: upload-images-destination
@ -21,11 +21,7 @@ SYMBOL: build-images-destination
or ; or ;
: factor-git-branch ( -- name ) : factor-git-branch ( -- name )
image-path parent-directory [ image-path parent-directory git-current-branch ;
{ "git" "rev-parse" "--abbrev-ref" "HEAD" }
utf8 <process-reader> stream-contents
[ blank? ] trim-tail
] with-directory ;
: git-branch-destination ( -- dest ) : git-branch-destination ( -- dest )
build-images-destination get build-images-destination get
@ -47,7 +43,14 @@ SYMBOL: build-images-destination
] each ] each
] with-file-writer ; ] with-file-writer ;
: scp-name ( -- path ) "scp" ; ! Windows scp doesn't like pathnames with colons, it treats them as hostnames.
! Workaround for uploading checksums.txt created with temp-file.
! e.g. C:\Users\\Doug\\AppData\\Local\\Temp/factorcode.org\\Factor/checksums.txt
! ssh: Could not resolve hostname c: no address associated with name
HOOK: scp-name os ( -- path )
M: object scp-name "scp" ;
M: windows scp-name "pscp" ;
: upload-images ( -- ) : upload-images ( -- )
[ [

View File

@ -38,9 +38,9 @@ M: cache-assoc dispose* clear-assoc ;
PRIVATE> PRIVATE>
: purge-cache ( cache -- ) : purge-cache ( cache -- )
dup [ assoc>> ] [ max-age>> ] bi V{ } clone [ [ assoc>> ] [ max-age>> ] bi V{ } clone [
'[ '[
nip dup age>> 1 + [ >>age ] keep nip dup age>> 1 + [ >>age ] keep
_ < [ drop t ] [ _ dispose-to f ] if _ < [ drop t ] [ _ dispose-to f ] if
] assoc-filter >>assoc drop ] assoc-filter! drop
] keep [ last rethrow ] unless-empty ; ] keep [ last rethrow ] unless-empty ;

View File

@ -40,10 +40,10 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
GENERIC: leap-year? ( obj -- ? ) GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? M: integer leap-year? ( year -- ? )
dup 100 divisor? 400 4 ? divisor? ; dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ; year>> leap-year? ;
: (days-in-month) ( year month -- n ) : (days-in-month) ( year month -- n )
@ -121,10 +121,10 @@ GENERIC: easter ( obj -- obj' )
h l + 7 m * - 114 + 31 /mod 1 + ; h l + 7 m * - 114 + 31 /mod 1 + ;
M: integer easter M: integer easter ( year -- timestamp )
dup easter-month-day <date> ; dup easter-month-day <date> ;
M: timestamp easter M: timestamp easter ( timestamp -- timestamp )
clone clone
dup year>> easter-month-day dup year>> easter-month-day
swapd >>day swap >>month ; swapd >>day swap >>month ;
@ -167,52 +167,52 @@ GENERIC: +second ( timestamp x -- timestamp )
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
[ 3 >>month 1 >>day ] when ; [ 3 >>month 1 >>day ] when ;
M: integer +year M: integer +year ( timestamp n -- timestamp )
[ + ] curry change-year adjust-leap-year ; [ + ] curry change-year adjust-leap-year ;
M: real +year M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years ) : months/years ( n -- months years )
12 /rem [ 1 - 12 ] when-zero swap ; inline 12 /rem [ 1 - 12 ] when-zero swap ; inline
M: integer +month M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ; [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
M: real +month M: real +month ( timestamp n -- timestamp )
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ; [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
M: integer +day M: integer +day ( timestamp n -- timestamp )
[ [
over >date< julian-day-number + julian-day-number>date over >date< julian-day-number + julian-day-number>date
[ >>year ] [ >>month ] [ >>day ] tri* [ >>year ] [ >>month ] [ >>day ] tri*
] unless-zero ; ] unless-zero ;
M: real +day M: real +day ( timestamp n -- timestamp )
[ float>whole-part swapd 24 * +hour swap +day ] unless-zero ; [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
: hours/days ( n -- hours days ) : hours/days ( n -- hours days )
24 /rem swap ; 24 /rem swap ;
M: integer +hour M: integer +hour ( timestamp n -- timestamp )
[ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ; [ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
M: real +hour M: real +hour ( timestamp n -- timestamp )
float>whole-part swapd 60 * +minute swap +hour ; float>whole-part swapd 60 * +minute swap +hour ;
: minutes/hours ( n -- minutes hours ) : minutes/hours ( n -- minutes hours )
60 /rem swap ; 60 /rem swap ;
M: integer +minute M: integer +minute ( timestamp n -- timestamp )
[ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ; [ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
M: real +minute M: real +minute ( timestamp n -- timestamp )
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
: seconds/minutes ( n -- seconds minutes ) : seconds/minutes ( n -- seconds minutes )
60 /rem swap >integer ; 60 /rem swap >integer ;
M: number +second M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ; [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
: (time+) ( timestamp duration -- timestamp' duration ) : (time+) ( timestamp duration -- timestamp' duration )
@ -291,7 +291,8 @@ GENERIC: time- ( time1 time2 -- time3 )
[ neg +year 0 ] change-year drop [ neg +year 0 ] change-year drop
] if ; ] if ;
M: timestamp <=> [ >gmt tuple-slots ] compare ; M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: same-day? ( ts1 ts2 -- ? ) : same-day? ( ts1 ts2 -- ? )
[ >gmt >date< <date> ] same? ; [ >gmt >date< <date> ] same? ;
@ -375,9 +376,8 @@ M: duration time-
GENERIC: days-in-year ( obj -- n ) GENERIC: days-in-year ( obj -- n )
M: integer days-in-year leap-year? 366 365 ? ; M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
M: timestamp days-in-year year>> days-in-year ;
: days-in-month ( timestamp -- n ) : days-in-month ( timestamp -- n )
>date< drop (days-in-month) ; >date< drop (days-in-month) ;

View File

@ -52,15 +52,15 @@ MACRO: formatted ( spec -- quot )
GENERIC: day. ( obj -- ) GENERIC: day. ( obj -- )
M: integer day. M: integer day. ( n -- )
number>string dup length 2 < [ bl ] when write ; number>string dup length 2 < [ bl ] when write ;
M: timestamp day. M: timestamp day. ( timestamp -- )
day>> day. ; day>> day. ;
GENERIC: month. ( obj -- ) GENERIC: month. ( obj -- )
M: array month. M: array month. ( pair -- )
first2 first2
[ month-name write bl number>string print ] [ month-name write bl number>string print ]
[ 1 zeller-congruence ] [ 1 zeller-congruence ]
@ -71,15 +71,15 @@ M: array month.
1 + + 7 mod zero? [ nl ] [ bl ] if 1 + + 7 mod zero? [ nl ] [ bl ] if
] with each-integer nl ; ] with each-integer nl ;
M: timestamp month. M: timestamp month. ( timestamp -- )
[ year>> ] [ month>> ] bi 2array month. ; [ year>> ] [ month>> ] bi 2array month. ;
GENERIC: year. ( obj -- ) GENERIC: year. ( obj -- )
M: integer year. M: integer year. ( n -- )
12 [ 1 + 2array month. nl ] with each-integer ; 12 [ 1 + 2array month. nl ] with each-integer ;
M: timestamp year. M: timestamp year. ( timestamp -- )
year>> year. ; year>> year. ;
: timestamp>mdtm ( timestamp -- str ) : timestamp>mdtm ( timestamp -- str )

View File

@ -1 +0,0 @@
time

View File

@ -31,7 +31,7 @@ IN: calendar.unix
: timezone-name ( -- string ) : timezone-name ( -- string )
get-time zone>> ; get-time zone>> ;
M: unix gmt-offset M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ; get-time gmtoff>> 3600 /mod 60 /mod ;
: current-timeval ( -- timeval ) : current-timeval ( -- timeval )

View File

@ -28,10 +28,10 @@ IN: calendar.windows
[ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ] [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
} cleave instant <timestamp> ; } cleave instant <timestamp> ;
M: windows gmt-offset M: windows gmt-offset ( -- hours minutes seconds )
TIME_ZONE_INFORMATION <struct> TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation { dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error ] } { TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] } { TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
{ TIME_ZONE_ID_STANDARD [ Bias>> ] } { TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] } { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }

View File

@ -31,11 +31,11 @@ GENERIC: from ( channel -- value )
PRIVATE> PRIVATE>
M: channel to M: channel to ( value channel -- )
dup receivers>> dup receivers>>
[ dup wait to ] [ nip (to) ] if-empty ; [ dup wait to ] [ nip (to) ] if-empty ;
M: channel from M: channel from ( channel -- value )
[ self ] dip [ self ] dip
notify senders>> notify senders>>
[ (from) ] unless-empty [ (from) ] unless-empty

View File

@ -60,10 +60,10 @@ C: <remote-channel> remote-channel
PRIVATE> PRIVATE>
M: remote-channel to M: remote-channel to ( value remote-channel -- )
[ id>> swap to-message boa ] keep send-message drop ; [ id>> swap to-message boa ] keep send-message drop ;
M: remote-channel from M: remote-channel from ( remote-channel -- value )
[ id>> from-message boa ] keep send-message ; [ id>> from-message boa ] keep send-message ;
[ [

View File

@ -8,10 +8,10 @@ SINGLETON: adler-32
CONSTANT: adler-32-modulus 65521 CONSTANT: adler-32-modulus 65521
M: adler-32 checksum-bytes M: adler-32 checksum-bytes ( bytes checksum -- value )
drop drop
[ sum 1 + ] [ sum 1 + ]
[ [ dup length [1,b] <reversed> vdot ] [ length ] bi + ] bi [ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
[ adler-32-modulus mod ] bi@ 16 shift bitor ; [ adler-32-modulus mod ] bi@ 16 shift bitor ;
INSTANCE: adler-32 checksum INSTANCE: adler-32 checksum

View File

@ -5,7 +5,7 @@ IN: checksums.bsd
SINGLETON: bsd SINGLETON: bsd
M: bsd checksum-bytes M: bsd checksum-bytes ( bytes checksum -- value )
drop 0 [ drop 0 [
[ [ -1 shift ] [ 1 bitand 15 shift ] bi + ] dip [ [ -1 shift ] [ 1 bitand 15 shift ] bi + ] dip
+ 0xffff bitand + 0xffff bitand

View File

@ -38,67 +38,67 @@ CONSTANT: fnv1-256-basis 0xdd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b
CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
M: fnv1-32 checksum-bytes M: fnv1-32 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-32-basis swap fnv1-32-basis swap
[ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ; [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
M: fnv1a-32 checksum-bytes M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-32-basis swap fnv1-32-basis swap
[ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ; [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
M: fnv1-64 checksum-bytes M: fnv1-64 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-64-basis swap fnv1-64-basis swap
[ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ; [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
M: fnv1a-64 checksum-bytes M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-64-basis swap fnv1-64-basis swap
[ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ; [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
M: fnv1-128 checksum-bytes M: fnv1-128 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-128-basis swap fnv1-128-basis swap
[ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ; [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
M: fnv1a-128 checksum-bytes M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-128-basis swap fnv1-128-basis swap
[ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ; [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
M: fnv1-256 checksum-bytes M: fnv1-256 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-256-basis swap fnv1-256-basis swap
[ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ; [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
M: fnv1a-256 checksum-bytes M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-256-basis swap fnv1-256-basis swap
[ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ; [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
M: fnv1-512 checksum-bytes M: fnv1-512 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-512-basis swap fnv1-512-basis swap
[ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ; [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
M: fnv1a-512 checksum-bytes M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-512-basis swap fnv1-512-basis swap
[ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ; [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
M: fnv1-1024 checksum-bytes M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-1024-basis swap fnv1-1024-basis swap
[ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ; [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
M: fnv1a-1024 checksum-bytes M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
drop drop
fnv1-1024-basis swap fnv1-1024-basis swap
[ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ; [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;

View File

@ -47,7 +47,7 @@ CONSTANT: n 0xe6546b64
PRIVATE> PRIVATE>
M: murmur3-32 checksum-bytes M: murmur3-32 checksum-bytes ( bytes checksum -- value )
seed>> 32 bits main-loop end-case avalanche ; seed>> 32 bits main-loop end-case avalanche ;
INSTANCE: murmur3-32 checksum INSTANCE: murmur3-32 checksum

View File

@ -38,13 +38,13 @@ M: evp-md-context dispose*
: set-digest ( name ctx -- ) : set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
M: openssl-checksum initialize-checksum-state M: openssl-checksum initialize-checksum-state ( checksum -- evp-md-context )
maybe-init-ssl name>> <evp-md-context> [ set-digest ] keep ; maybe-init-ssl name>> <evp-md-context> [ set-digest ] keep ;
M: evp-md-context add-checksum-bytes M: evp-md-context add-checksum-bytes ( ctx bytes -- ctx' )
[ dup handle>> ] dip dup length EVP_DigestUpdate ssl-error ; [ dup handle>> ] dip dup length EVP_DigestUpdate ssl-error ;
M: evp-md-context get-checksum M: evp-md-context get-checksum ( ctx -- value )
handle>> handle>>
{ { int EVP_MAX_MD_SIZE } int } { { int EVP_MAX_MD_SIZE } int }
[ EVP_DigestFinal_ex ssl-error ] with-out-parameters [ EVP_DigestFinal_ex ssl-error ] with-out-parameters

View File

@ -116,7 +116,7 @@ M: struct-mirror delete-at
M: struct-mirror clear-assoc M: struct-mirror clear-assoc
object>> reset-struct-slots ; object>> reset-struct-slots ;
M: struct-mirror >alist M: struct-mirror >alist ( mirror -- alist )
object>> [ object>> [
[ drop "underlying" ] [ >c-ptr ] bi 2array 1array [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
] [ ] [

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -7,7 +7,7 @@ TUPLE: gray < color { gray read-only } { alpha read-only } ;
C: <gray> gray C: <gray> gray
M: gray >rgba M: gray >rgba ( gray -- rgba )
[ gray>> dup dup ] [ alpha>> ] bi <rgba> ; inline [ gray>> dup dup ] [ alpha>> ] bi <rgba> ; inline
M: gray red>> gray>> ; M: gray red>> gray>> ;

View File

@ -1 +0,0 @@
colors

View File

@ -6,15 +6,12 @@ lexer math math.parser sequences ;
IN: colors.hex IN: colors.hex
ERROR: invalid-hex-color hex ;
: hex>rgba ( hex -- rgba ) : hex>rgba ( hex -- rgba )
dup length { dup length {
{ 6 [ 2 group [ hex> 255 /f ] map first3 1.0 ] } { 6 [ 2 group [ hex> 255 /f ] map first3 1.0 ] }
{ 8 [ 2 group [ hex> 255 /f ] map first4 ] } { 8 [ 2 group [ hex> 255 /f ] map first4 ] }
{ 3 [ [ digit> 15 /f ] { } map-as first3 1.0 ] } { 3 [ [ digit> 15 /f ] { } map-as first3 1.0 ] }
{ 4 [ [ digit> 15 /f ] { } map-as first4 ] } { 4 [ [ digit> 15 /f ] { } map-as first4 ] }
[ drop invalid-hex-color ]
} case <rgba> ; } case <rgba> ;
: rgba>hex ( rgba -- hex ) : rgba>hex ( rgba -- hex )

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -29,7 +29,7 @@ C: <hsva> hsva
PRIVATE> PRIVATE>
M: hsva >rgba M: hsva >rgba ( hsva -- rgba )
[ [
dup Hi dup Hi
{ {

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -61,7 +61,7 @@ C: <ryba> ryba
PRIVATE> PRIVATE>
M: ryba >rgba M: ryba >rgba ( ryba -- rgba )
[ [
[ red>> ] [ yellow>> ] [ blue>> ] tri [ red>> ] [ yellow>> ] [ blue>> ] tri
[ ryb>rgb ] normalized [ ryb>rgb ] normalized

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1 +0,0 @@
colors

View File

@ -1,11 +1,11 @@
USING: help.markup help.syntax io.pathnames strings system vocabs vocabs.loader ; USING: help.markup help.syntax strings system vocabs vocabs.loader ;
IN: command-line IN: command-line
HELP: run-bootstrap-init HELP: run-bootstrap-init
{ $description "Runs the bootstrap initialization file in the user's " { $link home } " directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } "." } ; { $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } "." } ;
HELP: run-user-init HELP: run-user-init
{ $description "Runs the startup initialization file in the user's " { $link home } " directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } "." } ; { $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } "." } ;
HELP: load-vocab-roots HELP: load-vocab-roots
{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } "." } ; { $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } "." } ;
@ -117,7 +117,7 @@ $nl
{ $subsections load-vocab-roots } ; { $subsections load-vocab-roots } ;
ARTICLE: "rc-files" "Running code on startup" ARTICLE: "rc-files" "Running code on startup"
"Factor looks for three optional files in the user's " { $link home } " directory." "Factor looks for three optional files in your home directory."
{ $subsections { $subsections
".factor-boot-rc" ".factor-boot-rc"
".factor-rc" ".factor-rc"
@ -125,6 +125,12 @@ ARTICLE: "rc-files" "Running code on startup"
} }
"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files." "The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
$nl $nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
"USE: command-line"
"\".factor-rc\" rc-path print"
"\".factor-boot-rc\" rc-path print"
}
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up your developer name:" "Here is an example " { $snippet ".factor-boot-rc" } " which sets up your developer name:"
{ $code { $code
"USING: tools.scaffold namespaces ;" "USING: tools.scaffold namespaces ;"
@ -133,8 +139,8 @@ $nl
ARTICLE: "command-line" "Command line arguments" ARTICLE: "command-line" "Command line arguments"
"Factor command line usage:" "Factor command line usage:"
{ $code "factor [options] [script] [arguments]" } { $code "factor [VM args...] [script] [args...]" }
"Zero or more options can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup using " { $link run-script } ". Any arguments after the script file are stored in the following variable, with no further processing by Factor itself:" "Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup using " { $link run-script } ". Any arguments after the script file are stored in the following variable, with no further processing by Factor itself:"
{ $subsections command-line } { $subsections command-line }
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:" "Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
{ $code "factor [system switches...] -run=<vocab name>" } { $code "factor [system switches...] -run=<vocab name>" }

View File

@ -24,6 +24,9 @@ SYMBOL: command-line
: (command-line) ( -- args ) : (command-line) ( -- args )
OBJ-ARGS special-object sift [ alien>native-string ] map ; OBJ-ARGS special-object sift [ alien>native-string ] map ;
: rc-path ( name -- path )
home prepend-path ;
: try-user-init ( file -- ) : try-user-init ( file -- )
"user-init" get swap '[ "user-init" get swap '[
_ [ ?run-file ] [ _ [ ?run-file ] [
@ -34,14 +37,14 @@ SYMBOL: command-line
] when ; ] when ;
: run-bootstrap-init ( -- ) : run-bootstrap-init ( -- )
"~/.factor-boot-rc" try-user-init ; ".factor-boot-rc" rc-path try-user-init ;
: run-user-init ( -- ) : run-user-init ( -- )
"~/.factor-rc" try-user-init ; ".factor-rc" rc-path try-user-init ;
: load-vocab-roots ( -- ) : load-vocab-roots ( -- )
"user-init" get [ "user-init" get [
"~/.factor-roots" dup exists? [ ".factor-roots" rc-path dup exists? [
utf8 file-lines harvest [ add-vocab-root ] each utf8 file-lines harvest [ add-vocab-root ] each
] [ drop ] if ] [ drop ] if
"roots" get [ "roots" get [

View File

@ -1,7 +1,7 @@
! Copyright (C) 2011 Joe Groff. ! Copyright (C) 2011 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators command-line eval io io.pathnames kernel USING: combinators command-line eval io io.pathnames kernel
layouts math math.parser namespaces system vocabs.loader ; namespaces system vocabs.loader ;
IN: command-line.startup IN: command-line.startup
: help? ( -- ? ) : help? ( -- ? )
@ -9,33 +9,35 @@ IN: command-line.startup
os windows? [ script get "/?" = or ] when ; os windows? [ script get "/?" = or ] when ;
: help. ( -- ) : help. ( -- )
"Usage: " write vm-path file-name write " [options] [script] [arguments] "Usage: " write vm-path file-name write " [Factor arguments] [script] [script arguments]
Options: Factor arguments:
-help print this message and exit -help print this message and exit
-version print the Factor version and exit -version print the Factor version and exit
-i=<image> load Factor image file <image> [" write vm-path file-stem write ".image] -i=<image> load Factor image file <image> (default " write vm-path file-stem write ".image)
-run=<vocab> run the MAIN: entry point of <vocab> -run=<vocab> run the MAIN: entry point of <vocab>
-run=listener run terminal listener -run=listener run terminal listener
-run=ui.tools run Factor development UI -run=ui.tools run Factor development UI
-e=<code> evaluate <code> -e=<code> evaluate <code>
-no-user-init suppress loading of .factor-rc -no-user-init suppress loading of .factor-rc
-datastack=<int> datastack size in KiB [" write cell 32 * number>string write "] -datastack=<int> datastack size in KiB
-retainstack=<int> retainstack size in KiB [" write cell 32 * number>string write "] -retainstack=<int> retainstack size in KiB
-callstack=<int> callstack size in KiB [" write cell cpu ppc? 256 128 ? * number>string write "] -callstack=<int> callstack size in KiB
-callbacks=<int> callback heap size in KiB [256] -callbacks=<int> callback heap size in KiB
-young=<int> young gc generation 0 size in MiB [" write cell 4 / number>string write "] -young=<int> young gc generation 0 size in MiB
-aging=<int> aging gc generation 1 size in MiB [" write cell 2 / number>string write "] -aging=<int> aging gc generation 1 size in MiB
-tenured=<int> tenured gc generation 2 size in MiB [" write cell 24 * number>string write "] -tenured=<int> tenured gc generation 2 size in MiB
-codeheap=<int> codeheap size in MiB [64] -codeheap=<int> codeheap size in MiB
-pic=<int> max pic size [3] -pic=<int> max pic size
-fep enter fep mode immediately -fep enter fep mode immediately
-no-signals turn off OS signal handling -no-signals turn off OS signal handling
-roots=<paths> '" write os windows? ";" ":" ? write "'-separated list of extra vocab root directories -console open console if possible
-roots=<paths> a list of \"" write os windows? ";" ":" ? write "\"-delimited extra vocab roots
Enter Enter
\"command-line\" help \"command-line\" help
from within Factor for more information. from within Factor for more information.
" write ; " write ;
: version? ( -- ? ) "version" get ; : version? ( -- ? ) "version" get ;

View File

@ -15,8 +15,6 @@ IN: compiler.cfg.builder.alien
0 stack-params set 0 stack-params set
V{ } clone reg-values set V{ } clone reg-values set
V{ } clone stack-values set V{ } clone stack-values set
0 int-reg-reps set
0 float-reg-reps set
@ @
reg-values get reg-values get
stack-values get stack-values get
@ -95,7 +93,7 @@ IN: compiler.cfg.builder.alien
[ stack-params get [ caller-stack-cleanup ] keep ] [ stack-params get [ caller-stack-cleanup ] keep ]
} cleave ; } cleave ;
M: #alien-invoke emit-node M: #alien-invoke emit-node ( block node -- block' )
params>> params>>
[ [
[ params>alien-insn-params ] [ params>alien-insn-params ]
@ -104,7 +102,7 @@ M: #alien-invoke emit-node
] ]
[ caller-return ] bi ; [ caller-return ] bi ;
M: #alien-indirect emit-node M: #alien-indirect emit-node ( block node -- block' )
params>> params>>
[ [
[ ds-pop ^^unbox-any-c-ptr ] dip [ ds-pop ^^unbox-any-c-ptr ] dip
@ -113,7 +111,7 @@ M: #alien-indirect emit-node
] ]
[ caller-return ] bi ; [ caller-return ] bi ;
M: #alien-assembly emit-node M: #alien-assembly emit-node ( block node -- block' )
params>> params>>
[ [
[ params>alien-insn-params ] [ params>alien-insn-params ]
@ -167,7 +165,7 @@ M: #alien-assembly emit-node
: emit-callback-outputs ( block params -- ) : emit-callback-outputs ( block params -- )
[ emit-callback-return ] keep callback-stack-cleanup ; [ emit-callback-return ] keep callback-stack-cleanup ;
M: #alien-callback emit-node M: #alien-callback emit-node ( block node -- block' )
dup params>> xt>> dup dup params>> xt>> dup
[ [
t cfg get frame-pointer?<< t cfg get frame-pointer?<<

View File

@ -10,30 +10,19 @@ IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area SYMBOL: struct-return-area
SYMBOLS: int-reg-reps float-reg-reps ;
: reg-reps ( reps -- int-reps float-reps )
[ second ] reject [ [ first int-rep? ] count ] [ length over - ] bi ;
: record-reg-reps ( reps -- reps )
dup reg-reps [ int-reg-reps +@ ] [ float-reg-reps +@ ] bi* ;
: unrecord-reg-reps ( reps -- reps )
dup reg-reps [ neg int-reg-reps +@ ] [ neg float-reg-reps +@ ] bi* ;
GENERIC: flatten-c-type ( c-type -- pairs ) GENERIC: flatten-c-type ( c-type -- pairs )
M: c-type flatten-c-type M: c-type flatten-c-type
rep>> f f 3array 1array record-reg-reps ; rep>> f f 3array 1array ;
M: long-long-type flatten-c-type M: long-long-type flatten-c-type
drop 2 [ int-rep long-long-on-stack? f 3array ] replicate record-reg-reps ; drop 2 [ int-rep long-long-on-stack? f 3array ] replicate ;
HOOK: flatten-struct-type cpu ( type -- pairs ) HOOK: flatten-struct-type cpu ( type -- pairs )
HOOK: flatten-struct-type-return cpu ( type -- pairs ) HOOK: flatten-struct-type-return cpu ( type -- pairs )
M: object flatten-struct-type M: object flatten-struct-type
heap-size cell align cell /i { int-rep f f } <array> record-reg-reps ; heap-size cell align cell /i { int-rep f f } <array> ;
M: struct-c-type flatten-c-type M: struct-c-type flatten-c-type
flatten-struct-type ; flatten-struct-type ;
@ -81,14 +70,14 @@ M: c-type unbox
[ swap ^^unbox ] [ swap ^^unbox ]
} case 1array } case 1array
] ]
[ drop f f 3array 1array ] 2bi record-reg-reps ; [ drop f f 3array 1array ] 2bi ;
M: long-long-type unbox M: long-long-type unbox
[ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array
int-rep long-long-on-stack? long-long-odd-register? 3array int-rep long-long-on-stack? long-long-odd-register? 3array
int-rep long-long-on-stack? f 3array 2array record-reg-reps ; int-rep long-long-on-stack? f 3array 2array ;
M: struct-c-type unbox M: struct-c-type unbox ( src c-type -- vregs reps )
[ ^^unbox-any-c-ptr ] dip explode-struct ; [ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type ) : frob-struct ( c-type -- c-type )

View File

@ -8,11 +8,11 @@ SYMBOL: stack-params
GENERIC: alloc-stack-param ( rep -- n ) GENERIC: alloc-stack-param ( rep -- n )
M: object alloc-stack-param M: object alloc-stack-param ( rep -- n )
stack-params get stack-params get
[ rep-size cell align stack-params +@ ] dip ; [ rep-size cell align stack-params +@ ] dip ;
M: float-rep alloc-stack-param M: float-rep alloc-stack-param ( rep -- n )
stack-params get swap rep-size stack-params get swap rep-size
[ cell align stack-params +@ ] keep [ cell align stack-params +@ ] keep
float-right-align-on-stack? [ + ] [ drop ] if ; float-right-align-on-stack? [ + ] [ drop ] if ;

View File

@ -71,7 +71,7 @@ GENERIC: emit-node ( block node -- block' )
##branch, [ begin-basic-block ] dip ##branch, [ begin-basic-block ] dip
[ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ; [ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
M: #recursive emit-node M: #recursive emit-node ( block node -- block' )
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if ! #if
@ -109,28 +109,28 @@ M: #recursive emit-node
! loc>vreg sync ! loc>vreg sync
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ; ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
M: #if emit-node M: #if emit-node ( block node -- block' )
{ {
{ [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ emit-actual-if ] [ emit-actual-if ]
} cond ; } cond ;
M: #dispatch emit-node M: #dispatch emit-node ( block node -- block' )
! Inputs to the final instruction need to be copied because of ! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg, ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though. ! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ; ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
M: #call emit-node M: #call emit-node ( block node -- block' )
dup word>> dup "intrinsic" word-prop [ dup word>> dup "intrinsic" word-prop [
nip call( block #call -- block' ) nip call( block #call -- block' )
] [ swap call-height emit-call ] if* ; ] [ swap call-height emit-call ] if* ;
M: #call-recursive emit-node M: #call-recursive emit-node ( block node -- block' )
[ label>> id>> ] [ call-height ] bi emit-call ; [ label>> id>> ] [ call-height ] bi emit-call ;
M: #push emit-node M: #push emit-node ( block node -- block )
literal>> ^^load-literal ds-push ; literal>> ^^load-literal ds-push ;
! #shuffle ! #shuffle
@ -157,7 +157,7 @@ M: #push emit-node
[ make-input-map ] [ mapping>> ] [ extract-outputs ] tri [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
[ [ of of peek-loc ] 2with map ] 2with map ; [ [ of of peek-loc ] 2with map ] 2with map ;
M: #shuffle emit-node M: #shuffle emit-node ( block node -- block )
[ out-vregs/stack ] keep store-height-changes [ out-vregs/stack ] keep store-height-changes
first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ; first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
@ -167,14 +167,14 @@ M: #shuffle emit-node
t >>kill-block? t >>kill-block?
##safepoint, ##epilogue, ##return, ; ##safepoint, ##epilogue, ##return, ;
M: #return emit-node M: #return emit-node ( block node -- block' )
drop end-word ; drop end-word ;
M: #return-recursive emit-node M: #return-recursive emit-node ( block node -- block' )
label>> id>> loops get key? [ ] [ end-word ] if ; label>> id>> loops get key? [ ] [ end-word ] if ;
! #terminate ! #terminate
M: #terminate emit-node M: #terminate emit-node ( block node -- block' )
drop ##no-tco, end-basic-block f ; drop ##no-tco, end-basic-block f ;
! No-op nodes ! No-op nodes

View File

@ -7,41 +7,41 @@ IN: compiler.cfg
HELP: basic-block HELP: basic-block
{ $class-description { $class-description
"Factors representation of a basic block in the Call Flow Graph (CFG). A basic block is a sequence of instructions that always are executed sequentially and doesn't contain any internal branching. It has the following slots:" "Factors representation of a basic block in the Call Flow Graph (CFG). A basic block is a sequence of instructions that always are executed sequentially and doesn't contain any internal branching. It has the following slots:"
{ $slots { $table
{ {
"number" { $slot "number" }
{ "The blocks sequence number. Generated by calling " { $link number-blocks } "." } { "The blocks sequence number. Generated by calling " { $link number-blocks } "." }
} }
{ {
"successors" { $slot "successors" }
{ "A " { $link vector } " of basic blocks that may be executed directly after this block. Most blocks only have one successor but a block that checks where an if-condition should branch to would have two for example." } { "A " { $link vector } " of basic blocks that may be executed directly after this block. Most blocks only have one successor but a block that checks where an if-condition should branch to would have two for example." }
} }
{ {
"predecessors" { $slot "predecessors" }
{ "The opposite of successors -- a " { $link vector } " of basic blocks from which the execution may have arrived into this block." } { "The opposite of successors -- a " { $link vector } " of basic blocks from which the execution may have arrived into this block." }
} }
{ {
"instructions" { $slot "instructions" }
{ "A " { $link vector } " of " { $link insn } " tuples which form the instructions of the basic block." } { "A " { $link vector } " of " { $link insn } " tuples which form the instructions of the basic block." }
} }
{ {
"kill-block?" { $slot "kill-block?" }
{ "The first and the last block in a cfg and all blocks containing " { $link ##call } " instructions are kill blocks. Kill blocks can't be optimized so they are omitted from certain optimization steps." } { "The first and the last block in a cfg and all blocks containing " { $link ##call } " instructions are kill blocks. Kill blocks can't be optimized so they are omitted from certain optimization steps." }
} }
{ {
"height" { $slot "height" }
"Block's height as a " { $link height-state } ". What the heights of the block was at entry and how much they were increased in the block." "Block's height as a " { $link height-state } ". What the heights of the block was at entry and how much they were increased in the block."
} }
{ {
"replaces" { $slot "replaces" }
{ "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." } { "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." }
} }
{ {
"peeks" { $slot "peeks" }
{ "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." } { "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." }
} }
{ {
"kills" { $slot "kills" }
{ "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." } { "Used by " { $vocab-link "compiler.cfg.stacks.local" } " for local stack analysis." }
} }
} }
@ -60,12 +60,12 @@ HELP: <cfg>
HELP: cfg HELP: cfg
{ $class-description { $class-description
"Call flow graph. It has the following slots:" "Call flow graph. It has the following slots:"
{ $slots { $table
{ "entry" { "Root " { $link basic-block } " of the graph." } } { { $slot "entry" } { "Root " { $link basic-block } " of the graph." } }
{ "word" { "The " { $link word } " the cfg is produced from." } } { { $slot "word" } { "The " { $link word } " the cfg is produced from." } }
{ "post-order" { "The blocks of the cfg in a post order traversal " { $link sequence } "." } } { { $slot "post-order" } { "The blocks of the cfg in a post order traversal " { $link sequence } "." } }
{ "stack-frame" { { $link stack-frame } " of the cfg." } } { { $slot "stack-frame" } { { $link stack-frame } " of the cfg." } }
{ "frame-pointer?" { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link #alien-callback } " nodes does need it. If the slot is " { $link t } ", then the frame pointer register (" { $link RBP } " on x86.64 archs) will not be clobbered by register allocation. See " { $vocab-link "compiler.cfg.linear-scan" } " for details." } } { { $slot "frame-pointer?" } { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link #alien-callback } " nodes does need it. If the slot is " { $link t } ", then the frame pointer register (" { $link RBP } " on x86.64 archs) will not be clobbered by register allocation. See " { $vocab-link "compiler.cfg.linear-scan" } " for details." } }
} }
} }
{ $see-also <cfg> post-order } ; { $see-also <cfg> post-order } ;

View File

@ -9,27 +9,27 @@ IN: compiler.cfg.instructions
HELP: ##alien-invoke HELP: ##alien-invoke
{ $class-description { $class-description
"An instruction for calling a function in a dynamically linked library. It has the following slots:" "An instruction for calling a function in a dynamically linked library. It has the following slots:"
{ $slots { $table
{ {
"dead-outputs" { $slot "dead-outputs" }
{ "A sequence of return values from the function that the compiler.cfg.dce pass has figured out are not used." } { "A sequence of return values from the function that the compiler.cfg.dce pass has figured out are not used." }
} }
{ {
"reg-inputs" { $slot "reg-inputs" }
{ "Registers to use for the arguments to the function call. Each sequence item is a 3-tuple consisting of a " { $link spill-slot } ", register representation and a register. When the function is called, the parameter is copied from the spill slot to the given register." } { "Registers to use for the arguments to the function call. Each sequence item is a 3-tuple consisting of a " { $link spill-slot } ", register representation and a register. When the function is called, the parameter is copied from the spill slot to the given register." }
} }
{ {
"stack-inputs" { $slot "stack-inputs" }
{ "Stack slots used for the arguments to the function call." } { "Stack slots used for the arguments to the function call." }
} }
{ {
"reg-outputs" { $slot "reg-outputs" }
{ "If the called function returns a value, then this slot is a one-element sequence containing a 3-tuple describing which register is used for the return value." } { "If the called function returns a value, then this slot is a one-element sequence containing a 3-tuple describing which register is used for the return value." }
} }
{ "symbols" { "Name of the function to call." } } { { $slot "symbols" } { "Name of the function to call." } }
{ "dll" { "A dll handle or " { $link f } "." } } { { $slot "dll" } { "A dll handle or " { $link f } "." } }
{ {
"gc-map" { $slot "gc-map" }
{ {
"If the invoked C function calls Factor code which triggers a GC, then a " "If the invoked C function calls Factor code which triggers a GC, then a "
{ $link gc-map } { $link gc-map }
@ -44,9 +44,9 @@ HELP: ##alien-invoke
HELP: ##alien-indirect HELP: ##alien-indirect
{ $class-description { $class-description
"An instruction representing an indirect alien call. The first item on the datastack is a pointer to the function to call and the parameters follows. It has the following slots:" "An instruction representing an indirect alien call. The first item on the datastack is a pointer to the function to call and the parameters follows. It has the following slots:"
{ $slots { $table
{ "src" { "Spill slot containing the function pointer." } } { { $slot "src" } { "Spill slot containing the function pointer." } }
{ "reg-outputs" { "Sequence of output values passed in registers." } } { { $slot "reg-outputs" } { "Sequence of output values passed in registers." } }
} }
} }
{ $see-also alien-indirect %alien-indirect } ; { $see-also alien-indirect %alien-indirect } ;
@ -54,11 +54,11 @@ HELP: ##alien-indirect
HELP: ##allot HELP: ##allot
{ $class-description { $class-description
"An instruction for allocating memory in the nursery. Usually the instruction is preceded by " { $link ##check-nursery-branch } " which checks that there is enough room in the nursery to allocate. It has the following slots:" "An instruction for allocating memory in the nursery. Usually the instruction is preceded by " { $link ##check-nursery-branch } " which checks that there is enough room in the nursery to allocate. It has the following slots:"
{ $slots { $table
{ "dst" { "Register to put the pointer to the memory in." } } { { $slot "dst" } { "Register to put the pointer to the memory in." } }
{ "size" { "Number of bytes to allocate." } } { { $slot "size" } { "Number of bytes to allocate." } }
{ "class-of" { "Class of object to allocate, e.g " { $link tuple } " or " { $link array } "." } } { { $slot "class-of" } { "Class of object to allocate, e.g " { $link tuple } " or " { $link array } "." } }
{ "temp" { "Temporary register to clobber." } } { { $slot "temp" } { "Temporary register to clobber." } }
} }
} ; } ;
@ -79,8 +79,8 @@ HELP: ##box-alien
HELP: ##call HELP: ##call
{ $class-description { $class-description
"An instruction for calling a Factor word." "An instruction for calling a Factor word."
{ $slots { $table
{ "word" { "The word called." } } { { $slot "word" } { "The word called." } }
} }
} ; } ;
@ -89,11 +89,11 @@ HELP: ##check-nursery-branch
"Instruction that inserts a conditional branch to a " { $link basic-block } " that garbage collects the nursery. The " { $vocab-link "compiler.cfg.gc-checks" } " vocab goes through each block in the " { $link cfg } " and checks if it allocates memory. If it does, then this instruction is inserted in the cfg before that block and checks if there is enough available space in the nursery. If it isn't, then a basic block containing code for garbage collecting the nursery is executed." "Instruction that inserts a conditional branch to a " { $link basic-block } " that garbage collects the nursery. The " { $vocab-link "compiler.cfg.gc-checks" } " vocab goes through each block in the " { $link cfg } " and checks if it allocates memory. If it does, then this instruction is inserted in the cfg before that block and checks if there is enough available space in the nursery. If it isn't, then a basic block containing code for garbage collecting the nursery is executed."
$nl $nl
"It has the following slots:" "It has the following slots:"
{ $slots { $table
{ "size" { "Number of bytes the next block in the cfg will allocate." } } { { $slot "size" } { "Number of bytes the next block in the cfg will allocate." } }
{ "cc" { "A comparison symbol." } } { { $slot "cc" } { "A comparison symbol." } }
{ "temp1" { "First register that will be clobbered." } } { { $slot "temp1" } { "First register that will be clobbered." } }
{ "temp2" { "Second register that will be clobbered." } } { { $slot "temp2" } { "Second register that will be clobbered." } }
} }
} }
{ $see-also %check-nursery-branch } ; { $see-also %check-nursery-branch } ;
@ -101,8 +101,8 @@ HELP: ##check-nursery-branch
HELP: ##compare-float-ordered-branch HELP: ##compare-float-ordered-branch
{ $class-description { $class-description
"It has the following slots:" "It has the following slots:"
{ $slots { $table
{ "cc" { "Comparison symbol." } } { { $slot "cc" } { "Comparison symbol." } }
} }
} ; } ;
@ -119,8 +119,8 @@ HELP: ##compare-integer
HELP: ##copy HELP: ##copy
{ $class-description "Instruction that copies a value from one register to another of the same type. For example, you can copy between two gprs or two simd registers but not across. It has the following slots:" { $class-description "Instruction that copies a value from one register to another of the same type. For example, you can copy between two gprs or two simd registers but not across. It has the following slots:"
{ $slots { $table
{ "rep" { "Value representation. Both the source and destination register must have the same representation." } } { { $slot "rep" } { "Value representation. Both the source and destination register must have the same representation." } }
} }
} ; } ;
@ -139,8 +139,8 @@ HELP: ##inc
HELP: ##jump HELP: ##jump
{ $class-description { $class-description
"An uncondiation jump instruction. It has the following slots:" "An uncondiation jump instruction. It has the following slots:"
{ $slots { $table
{ "word" { "Word whose address the instruction is jumping to." } } { { $slot "word" } { "Word whose address the instruction is jumping to." } }
} }
"Note that the optimizer is sometimes able to optimize away a " { $link ##call } " and " { $link ##return } " pair into one ##jump instruction." "Note that the optimizer is sometimes able to optimize away a " { $link ##call } " and " { $link ##return } " pair into one ##jump instruction."
} ; } ;
@ -156,9 +156,9 @@ HELP: ##load-memory-imm
HELP: ##load-reference HELP: ##load-reference
{ $class-description { $class-description
"An instruction for loading a pointer to an object into a register. It has the following slots:" "An instruction for loading a pointer to an object into a register. It has the following slots:"
{ $slots { $table
{ "dst" { "Register to load the pointer into." } } { { $slot "dst" } { "Register to load the pointer into." } }
{ "obj" { "A Factor object." } } { { $slot "obj" } { "A Factor object." } }
} }
} ; } ;
@ -174,10 +174,10 @@ HELP: ##load-vector
HELP: ##local-allot HELP: ##local-allot
{ $class-description { $class-description
"An instruction for allocating memory in the words own stack frame. It's mostly used for receiving data from alien calls. It has the following slots:" "An instruction for allocating memory in the words own stack frame. It's mostly used for receiving data from alien calls. It has the following slots:"
{ $slots { $table
{ "dst" { "Register into which a pointer to the stack allocated memory is put." } } { { $slot "dst" } { "Register into which a pointer to the stack allocated memory is put." } }
{ "size" { "Number of bytes to allocate." } } { { $slot "size" } { "Number of bytes to allocate." } }
{ "offset" { } } { { $slot "offset" } { } }
} }
} }
{ $see-also ##allot } ; { $see-also ##allot } ;
@ -191,8 +191,8 @@ HELP: ##no-tco
HELP: ##parallel-copy HELP: ##parallel-copy
{ $class-description "An instruction for performing multiple copies. It allows for optimizations or (or prunings) if more than one source or destination vreg is the same. They are transformed into " { $link ##copy } " instructions in " { $link destruct-ssa } ". It has the following slots:" { $class-description "An instruction for performing multiple copies. It allows for optimizations or (or prunings) if more than one source or destination vreg is the same. They are transformed into " { $link ##copy } " instructions in " { $link destruct-ssa } ". It has the following slots:"
{ $slots { $table
{ "values" { "An assoc mapping source vregs to destinations." } } { { $slot "values" } { "An assoc mapping source vregs to destinations." } }
} }
} ; } ;
@ -205,9 +205,9 @@ HELP: ##peek
HELP: ##phi HELP: ##phi
{ $class-description { $class-description
"A special kind of instruction used to mark control flow. It is inserted by the " { $vocab-link "compiler.cfg.ssa.construction" } " vocab. It has the following slots:" "A special kind of instruction used to mark control flow. It is inserted by the " { $vocab-link "compiler.cfg.ssa.construction" } " vocab. It has the following slots:"
{ $slots { $table
{ "inputs" { "An assoc containing as keys the blocks/block numbers where the vreg was defined and as values the vreg. Why care about the blocks?" } } { { $slot "inputs" } { "An assoc containing as keys the blocks/block numbers where the vreg was defined and as values the vreg. Why care about the blocks?" } }
{ "dst" { "A merged vreg for the value." } } { { $slot "dst" } { "A merged vreg for the value." } }
} }
} ; } ;
@ -241,22 +241,22 @@ HELP: ##save-context
HELP: ##set-slot HELP: ##set-slot
{ $class-description { $class-description
"An instruction for the non-primitive, non-immediate variant of " { $link set-slot } ". It has the following slots:" "An instruction for the non-primitive, non-immediate variant of " { $link set-slot } ". It has the following slots:"
{ $slots { $table
{ "src" { "Object to put in the slot." } } { { $slot "src" } { "Object to put in the slot." } }
{ "obj" { "Object to set the slot on." } } { { $slot "obj" } { "Object to set the slot on." } }
{ "slot" { "Slot index." } } { { $slot "slot" } { "Slot index." } }
{ "tag" { "Type tag for obj." } } { { $slot "tag" } { "Type tag for obj." } }
} }
} ; } ;
HELP: ##set-slot-imm HELP: ##set-slot-imm
{ $class-description { $class-description
"An instruction for what? It has the following slots:" "An instruction for what? It has the following slots:"
{ $slots { $table
{ "src" { "Register containing the value to put in the slot." } } { { $slot "src" } { "Register containing the value to put in the slot." } }
{ "obj" { "Register containing the object to set the slot on.." } } { { $slot "obj" } { "Register containing the object to set the slot on.." } }
{ "slot" { "Slot index." } } { { $slot "slot" } { "Slot index." } }
{ "tag" { "Type tag for obj." } } { { $slot "tag" } { "Type tag for obj." } }
} }
} }
{ $see-also ##set-slot %set-slot-imm } ; { $see-also ##set-slot %set-slot-imm } ;
@ -268,10 +268,10 @@ HELP: ##single>double-float
HELP: ##shuffle-vector-imm HELP: ##shuffle-vector-imm
{ $class-description "Shuffles the vector in a SSE register according to the given shuffle pattern. It is used to extract a given element of the vector." { $class-description "Shuffles the vector in a SSE register according to the given shuffle pattern. It is used to extract a given element of the vector."
{ $slots { $table
{ "dst" { "Destination register to shuffle the vector to." } } { { $slot "dst" } { "Destination register to shuffle the vector to." } }
{ "src" { "Source register." } } { { $slot "src" } { "Source register." } }
{ "shuffle" { "Shuffling pattern." } } { { $slot "shuffle" } { "Shuffling pattern." } }
} }
} }
{ $see-also %shuffle-vector-imm } ; { $see-also %shuffle-vector-imm } ;
@ -279,31 +279,31 @@ HELP: ##shuffle-vector-imm
HELP: ##slot-imm HELP: ##slot-imm
{ $class-description { $class-description
"Instruction for reading a slot with a given index from an object." "Instruction for reading a slot with a given index from an object."
{ $slots { $table
{ "dst" { "Register to read the slot value into." } } { { $slot "dst" } { "Register to read the slot value into." } }
{ "obj" { "Register containing the object with the slot." } } { { $slot "obj" } { "Register containing the object with the slot." } }
{ "slot" { "Slot index." } } { { $slot "slot" } { "Slot index." } }
{ "tag" { "Type tag for obj." } } { { $slot "tag" } { "Type tag for obj." } }
} }
} { $see-also %slot-imm } ; } { $see-also %slot-imm } ;
HELP: ##spill HELP: ##spill
{ $class-description "Instruction that copies a value from a register to a " { $link spill-slot } "." { $class-description "Instruction that copies a value from a register to a " { $link spill-slot } "."
{ $slots { $table
{ "rep" { "Register representation which is necessary when spilling SIMD registers." } } { { $slot "rep" } { "Register representation which is necessary when spilling SIMD registers." } }
} }
} { $see-also ##reload } ; } { $see-also ##reload } ;
HELP: ##store-memory-imm HELP: ##store-memory-imm
{ $class-description "Instruction that copies an 8 byte value from a XMM register to a memory location addressed by a normal register. This instruction is often turned into a cheaper " { $link ##store-memory } " instruction in the " { $link value-numbering } " pass." { $class-description "Instruction that copies an 8 byte value from a XMM register to a memory location addressed by a normal register. This instruction is often turned into a cheaper " { $link ##store-memory } " instruction in the " { $link value-numbering } " pass."
{ $slots { $table
{ "base" { "Vreg that contains the base address." } } { { $slot "base" } { "Vreg that contains the base address." } }
{ {
"offset" { $slot "offset" }
{ "Offset in bytes from the address to where the data should be written." } { "Offset in bytes from the address to where the data should be written." }
} }
{ "rep" { "Value representation in the vector register." } } { { $slot "rep" } { "Value representation in the vector register." } }
{ "src" { "Vreg that contains the item to set." } } { { $slot "src" } { "Vreg that contains the item to set." } }
} }
} }
{ $see-also %store-memory-imm } ; { $see-also %store-memory-imm } ;
@ -314,9 +314,9 @@ HELP: ##test-branch
HELP: ##unbox-any-c-ptr HELP: ##unbox-any-c-ptr
{ $class-description "Instruction that unboxes a pointer in a register so that it can be fed to a C FFI function. For example, if 'src' points to a " { $link byte-array } ", then in 'dst' will be put a pointer to the first byte of that byte array." { $class-description "Instruction that unboxes a pointer in a register so that it can be fed to a C FFI function. For example, if 'src' points to a " { $link byte-array } ", then in 'dst' will be put a pointer to the first byte of that byte array."
{ $slots { $table
{ "dst" { "Destination register." } } { { $slot "dst" } { "Destination register." } }
{ "src" { "Source register." } } { { $slot "src" } { "Source register." } }
} }
} }
{ $see-also %unbox-any-c-ptr } ; { $see-also %unbox-any-c-ptr } ;
@ -327,10 +327,10 @@ HELP: ##unbox-long-long
HELP: ##vector>scalar HELP: ##vector>scalar
{ $class-description { $class-description
"This instruction is very similar to " { $link ##copy } "." "This instruction is very similar to " { $link ##copy } "."
{ $slots { $table
{ "dst" { "destination vreg" } } { { $slot "dst" } { "destination vreg" } }
{ "src" { "source vreg" } } { { $slot "src" } { "source vreg" } }
{ "rep" { "representation for the source vreg" } } { { $slot "rep" } { "representation for the source vreg" } }
} }
} }
{ $notes "The two vregs must not necessarily share the same representation." } { $notes "The two vregs must not necessarily share the same representation." }
@ -338,9 +338,9 @@ HELP: ##vector>scalar
HELP: ##vm-field HELP: ##vm-field
{ $class-description "Instruction for loading a pointer to a vm field." { $class-description "Instruction for loading a pointer to a vm field."
{ $slots { $table
{ "dst" { "Register to load the field into." } } { { $slot "dst" } { "Register to load the field into." } }
{ "offset" { "Offset of the field relative to the vm address." } } { { $slot "offset" } { "Offset of the field relative to the vm address." } }
} }
} }
{ $see-also %vm-field } ; { $see-also %vm-field } ;
@ -348,13 +348,13 @@ HELP: ##vm-field
HELP: ##write-barrier HELP: ##write-barrier
{ $class-description { $class-description
"An instruction for inserting a write barrier. This instruction is almost always inserted after a " { $link ##set-slot } " instruction. If the container object is in an older generation than the item inserted, this instruction guarantees that the item will not be garbage collected. It has the following slots:" "An instruction for inserting a write barrier. This instruction is almost always inserted after a " { $link ##set-slot } " instruction. If the container object is in an older generation than the item inserted, this instruction guarantees that the item will not be garbage collected. It has the following slots:"
{ $slots { $table
{ "src" { "Object to which the writer barrier refers." } } { { $slot "src" } { "Object to which the writer barrier refers." } }
{ "slot" { "Slot index of the object." } } { { $slot "slot" } { "Slot index of the object." } }
{ "scale" { "No idea." } } { { $slot "scale" } { "No idea." } }
{ "tag" { "Type tag for obj." } } { { $slot "tag" } { "Type tag for obj." } }
{ "temp1" { "First temporary register to clobber." } } { { $slot "temp1" } { "First temporary register to clobber." } }
{ "temp2" { "Second temporary register to clobber." } } { { $slot "temp2" } { "Second temporary register to clobber." } }
} }
} ; } ;
@ -396,13 +396,13 @@ HELP: gc-map-insn
HELP: gc-map HELP: gc-map
{ $class-description "A tuple that holds info necessary for a gc cycle to figure out where the gc root pointers are. It has the following slots:" { $class-description "A tuple that holds info necessary for a gc cycle to figure out where the gc root pointers are. It has the following slots:"
{ $slots { $table
{ {
"gc-roots" { $slot "gc-roots" }
{ { $link sequence } " of vregs or spill-slots" } { { $link sequence } " of vregs or spill-slots" }
} }
{ {
"derived-roots" { $slot "derived-roots" }
{ "An " { $link assoc } " of pairs of vregs or spill slots." } } { "An " { $link assoc } " of pairs of vregs or spill slots." } }
} }
"The 'gc-roots' and 'derived-roots' slots are initially vreg integers referencing objects that are live during the gc call and needs to be spilled so that they can be traced. In the " { $link emit-gc-map-insn } " word in " { $vocab-link "compiler.cfg.linear-scan.assignment" } " they are converted to spill slots which the collector is able to trace." "The 'gc-roots' and 'derived-roots' slots are initially vreg integers referencing objects that are live during the gc call and needs to be spilled so that they can be traced. In the " { $link emit-gc-map-insn } " word in " { $vocab-link "compiler.cfg.linear-scan.assignment" } " they are converted to spill slots which the collector is able to trace."

View File

@ -238,13 +238,13 @@ M: horizontal-cpu %horizontal-add-vector-reps signed-reps ;
M: horizontal-cpu %unpack-vector-head-reps signed-reps ; M: horizontal-cpu %unpack-vector-head-reps signed-reps ;
M: horizontal-cpu %unpack-vector-tail-reps signed-reps ; M: horizontal-cpu %unpack-vector-tail-reps signed-reps ;
! vdot ! v.
{ { ##dot-vector } } { { ##dot-vector } }
[ dot-cpu float-4-rep [ emit-simd-vdot ] test-emit ] [ dot-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test unit-test
{ { ##mul-vector ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } } { { ##mul-vector ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } }
[ horizontal-cpu float-4-rep [ emit-simd-vdot ] test-emit ] [ horizontal-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test unit-test
{ { { {
@ -253,7 +253,7 @@ unit-test
##merge-vector-head ##merge-vector-tail ##add-vector ##merge-vector-head ##merge-vector-tail ##add-vector
##vector>scalar ##vector>scalar
} } } }
[ simple-ops-cpu float-4-rep [ emit-simd-vdot ] test-emit ] [ simple-ops-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test unit-test
! vsqrt ! vsqrt

View File

@ -417,7 +417,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
] } ] }
} emit-vv-vector-op ; } emit-vv-vector-op ;
: emit-simd-vdot ( node -- ) : emit-simd-v. ( node -- )
{ {
[ ^^dot-vector ] [ ^^dot-vector ]
{ float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] } { float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] }
@ -667,7 +667,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
{ (simd-vmin) [ emit-simd-vmin ] } { (simd-vmin) [ emit-simd-vmin ] }
{ (simd-vmax) [ emit-simd-vmax ] } { (simd-vmax) [ emit-simd-vmax ] }
{ (simd-vavg) [ emit-simd-vavg ] } { (simd-vavg) [ emit-simd-vavg ] }
{ (simd-vdot) [ emit-simd-vdot ] } { (simd-v.) [ emit-simd-v. ] }
{ (simd-vsad) [ emit-simd-vsad ] } { (simd-vsad) [ emit-simd-vsad ] }
{ (simd-vsqrt) [ emit-simd-vsqrt ] } { (simd-vsqrt) [ emit-simd-vsqrt ] }
{ (simd-sum) [ emit-simd-sum ] } { (simd-sum) [ emit-simd-sum ] }

View File

@ -76,27 +76,26 @@ HELP: last-use?
HELP: live-interval-state HELP: live-interval-state
{ $class-description "A class encoding the \"liveness\" of a virtual register. It has the following slots:" { $class-description "A class encoding the \"liveness\" of a virtual register. It has the following slots:"
{ $slots { $table
{ "vreg" { "The vreg this live interval state is bound to." } } { { $slot "vreg" } { "The vreg this live interval state is bound to." } }
{ {
"reg" { $slot "reg" }
{ "The allocated register, set in the " { $link allocate-registers } " step." } { "The allocated register, set in the " { $link allocate-registers } " step." }
} }
{ {
"spill-rep" { $slot "spill-rep" }
{ { $link representation } " the vreg will have when it is spilled." } { { $link representation } " the vreg will have when it is spilled." }
} }
{ {
"spill-to" { $slot "spill-to" }
{ { $link spill-slot } " to use for spilling, if it needs to be spilled." } { { $link spill-slot } " to use for spilling, if it needs to be spilled." }
} }
{ {
"ranges" { $slot "ranges" }
{ "Inclusive ranges where the live interval is live. This is because the [start,end] interval can have gaps." } { "Inclusive ranges where the live interval is live. This is because the [start,end] interval can have gaps." }
} }
{ {
"uses" { $slot "uses" } { "sequence of insn# numbers which reference insructions that use the register in the live interval." }
{ "sequence of insn# numbers which reference insructions that use the register in the live interval." }
} }
} }
} }
@ -119,9 +118,9 @@ HELP: record-temp
HELP: sync-point HELP: sync-point
{ $class-description "A location where all live registers have to be spilled. For example when garbage collection is run or an alien ffi call is invoked. Figuring out where in the " { $link cfg } " the sync points are is done in the " { $link compute-live-intervals } " step. The tuple has the following slots:" { $class-description "A location where all live registers have to be spilled. For example when garbage collection is run or an alien ffi call is invoked. Figuring out where in the " { $link cfg } " the sync points are is done in the " { $link compute-live-intervals } " step. The tuple has the following slots:"
{ $slots { $table
{ "n" { "Set from an instructions sequence number." } } { { $slot "n" } { "Set from an instructions sequence number." } }
{ "keep-dst?" { "Boolean that determines whether registers are spilled around this sync point." } } { { $slot "keep-dst?" } { "Boolean that determines whether registers are spilled around this sync point." } }
} }
} }
{ $see-also cfg>sync-points clobber-insn hairy-clobber-insn insn } ; { $see-also cfg>sync-points clobber-insn hairy-clobber-insn insn } ;

View File

@ -35,7 +35,7 @@ GENERIC: visit-insn ( live-set insn -- )
: gen-uses ( live-set insn -- ) : gen-uses ( live-set insn -- )
uses-vregs [ swap conjoin ] with each ; inline uses-vregs [ swap conjoin ] with each ; inline
M: vreg-insn visit-insn M: vreg-insn visit-insn ( live-set insn -- )
[ kill-defs ] [ gen-uses ] 2bi ; [ kill-defs ] [ gen-uses ] 2bi ;
DEFER: lookup-base-pointer DEFER: lookup-base-pointer
@ -98,7 +98,7 @@ M: vreg-insn lookup-base-pointer* 2drop f ;
: fill-gc-map ( live-set gc-map -- ) : fill-gc-map ( live-set gc-map -- )
[ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ; [ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ;
M: gc-map-insn visit-insn M: gc-map-insn visit-insn ( live-set insn -- )
[ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ; [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
M: ##phi visit-insn kill-defs ; M: ##phi visit-insn kill-defs ;

View File

@ -8,9 +8,9 @@ HELP: sets-interfere?
HELP: vreg-info HELP: vreg-info
{ $class-description { $class-description
"Slots:" "Slots:"
{ $slots { $table
{ "vreg" { "The vreg the vreg-info is the info for." } } { { $slot "vreg" } { "The vreg the vreg-info is the info for." } }
{ "bb" { "The " { $link basic-block } " in which the vreg is defined." } } { { $slot "bb" } { "The " { $link basic-block } " in which the vreg is defined." } }
} }
} ; } ;

View File

@ -11,15 +11,15 @@ HELP: stack-frame
{ "One final " { $link cell } " of padding." } { "One final " { $link cell } " of padding." }
} }
"The stack frame is also aligned to a 16 byte boundary. It has the following slots:" "The stack frame is also aligned to a 16 byte boundary. It has the following slots:"
{ $slots { $table
{ "total-size" { "Total size of the stack frame." } } { { $slot "total-size" } { "Total size of the stack frame." } }
{ "params" { "Reserved parameter space." } } { { $slot "params" } { "Reserved parameter space." } }
{ "allot-area-base" { "Base offset of the allocation area." } } { { $slot "allot-area-base" } { "Base offset of the allocation area." } }
{ "allot-area-size" { "Number of bytes requires for the allocation area." } } { { $slot "allot-area-size" } { "Number of bytes requires for the allocation area." } }
{ "allot-area-align" { "This slot is always at least " { $link cell } " bytes." } } { { $slot "allot-area-align" } { "This slot is always at least " { $link cell } " bytes." } }
{ "spill-area-base" { "Base offset for the spill area." } } { { $slot "spill-area-base" } { "Base offset for the spill area." } }
{ "spill-area-size" { "Number of bytes requires for all spill slots." } } { { $slot "spill-area-size" } { "Number of bytes requires for all spill slots." } }
{ "spill-area-align" { "This slot is always at least " { $link cell } " bytes." } } { { $slot "spill-area-align" } { "This slot is always at least " { $link cell } " bytes." } }
} }
} }
{ $see-also align-stack } ; { $see-also align-stack } ;

View File

@ -29,21 +29,21 @@ HELP: global-loc>local
HELP: height-state HELP: height-state
{ $description "A tuple which keeps track of the stacks heights and increments of a " { $link basic-block } " during local analysis. The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:" { $description "A tuple which keeps track of the stacks heights and increments of a " { $link basic-block } " during local analysis. The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:"
{ $slots { $table
{ {
"ds-begin" { $slot "ds-begin" }
"Datastack height at the beginning of the block." "Datastack height at the beginning of the block."
} }
{ {
"rs-begin" { $slot "rs-begin" }
"Retainstack height at the beginning of the block." "Retainstack height at the beginning of the block."
} }
{ {
"ds-inc" { $slot "ds-inc" }
"Datastack change during the block." "Datastack change during the block."
} }
{ {
"rs-inc" { $slot "rs-inc" }
"Retainstack change during the block." "Retainstack change during the block."
} }
} }
@ -103,10 +103,10 @@ HELP: replaces
ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis" ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
"For each " { $link basic-block } " in the " { $link cfg } ", local stack analysis is performed. The analysis is started right after the block is created with " { $link begin-local-analysis } " and finished with " { $link end-local-analysis } ", when the construction of the block is complete. During the analysis, three sets containing stack locations are built:" "For each " { $link basic-block } " in the " { $link cfg } ", local stack analysis is performed. The analysis is started right after the block is created with " { $link begin-local-analysis } " and finished with " { $link end-local-analysis } ", when the construction of the block is complete. During the analysis, three sets containing stack locations are built:"
{ $slots { $list
{ "peeks" { " all stack locations that the block reads before writing" } } { { $slot "peeks" } " all stack locations that the block reads before writing" }
{ "replaces" { " all stack locations that the block writes" } } { { $slot "replaces" } " all stack locations that the block writes" }
{ "kills" { " all stack locations which become unavailable after the block ends because of the stack height being decremented. For example, if the block contains " { $link drop } ", then D: 0 will be contained in kills because that stack location will not be live anymore." } } { { $slot "kills" } " all stack locations which become unavailable after the block ends because of the stack height being decremented. For example, if the block contains " { $link drop } ", then D: 0 will be contained in kills because that stack location will not be live anymore." }
} }
"This is done while constructing the CFG. These sets are then used by the " { $link end-stack-analysis } " word to emit optimal sequences of " { $link ##peek } " and " { $link ##replace } " instructions to the cfg." "This is done while constructing the CFG. These sets are then used by the " { $link end-stack-analysis } " word to emit optimal sequences of " { $link ##peek } " and " { $link ##replace } " instructions to the cfg."
$nl $nl

View File

@ -33,7 +33,7 @@ T{ error-type-holder
{ type +compiler-error+ } { type +compiler-error+ }
{ word ":errors" } { word ":errors" }
{ plural "compiler errors" } { plural "compiler errors" }
{ icon "vocab:ui/tools/error-list/icons/compiler-error.png" } { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
{ quot [ compiler-errors get values ] } { quot [ compiler-errors get values ] }
{ forget-quot [ compiler-errors get delete-at ] } { forget-quot [ compiler-errors get delete-at ] }
} define-error-type } define-error-type
@ -51,7 +51,7 @@ T{ error-type-holder
{ type +linkage-error+ } { type +linkage-error+ }
{ word ":linkage" } { word ":linkage" }
{ plural "linkage errors" } { plural "linkage errors" }
{ icon "vocab:ui/tools/error-list/icons/linkage-error.png" } { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
{ quot [ linkage-errors get values ] } { quot [ linkage-errors get values ] }
{ forget-quot [ linkage-errors get delete-at ] } { forget-quot [ linkage-errors get delete-at ] }
{ fatal? f } { fatal? f }
@ -77,7 +77,7 @@ T{ error-type-holder
{ type +user-init-error+ } { type +user-init-error+ }
{ word ":user-init-errors" } { word ":user-init-errors" }
{ plural "rc file errors" } { plural "rc file errors" }
{ icon "vocab:ui/tools/error-list/icons/user-init-error.png" } { icon "vocab:ui/tools/error-list/icons/user-init-error.tiff" }
{ quot [ user-init-errors get-global values ] } { quot [ user-init-errors get-global values ] }
{ forget-quot [ user-init-errors get-global delete-at ] } { forget-quot [ user-init-errors get-global delete-at ] }
} define-error-type } define-error-type

View File

@ -2,7 +2,7 @@ USING: accessors alien alien.c-types alien.complex alien.data alien.libraries
alien.syntax arrays byte-arrays classes classes.struct combinators alien.syntax arrays byte-arrays classes classes.struct combinators
combinators.extras compiler compiler.test concurrency.promises continuations combinators.extras compiler compiler.test concurrency.promises continuations
destructors effects generalizations io io.backend io.pathnames destructors effects generalizations io io.backend io.pathnames
io.streams.string kernel kernel.private libc layouts locals math math.bitwise io.streams.string kernel kernel.private libc layouts math math.bitwise
math.private memory namespaces namespaces.private random parser quotations math.private memory namespaces namespaces.private random parser quotations
sequences slots.private specialized-arrays stack-checker stack-checker.errors sequences slots.private specialized-arrays stack-checker stack-checker.errors
system threads tools.test words ; system threads tools.test words ;
@ -963,117 +963,3 @@ FUNCTION: void* bug1021_test_3 ( c-string a )
{ } [ { } [
10000 [ 0 doit 33 assert= ] times 10000 [ 0 doit 33 assert= ] times
] unit-test ] unit-test
! Tests for System V AMD64 ABI
STRUCT: test_struct_66 { mem1 ulong } { mem2 ulong } ;
STRUCT: test_struct_68 { mem1 ulong } { mem2 ulong } { mem3 ulong } ;
STRUCT: test_struct_69 { mem1 float } { mem2 ulong } { mem3 ulong } ;
FUNCTION: ulong ffi_test_66 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e )
FUNCTION: ulong ffi_test_67 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e ulong _f )
FUNCTION: ulong ffi_test_68 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_68 e test_struct_66 _f )
FUNCTION: ulong ffi_test_69 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_69 e test_struct_66 _f )
FUNCTION: ulong ffi_test_70 ( test_struct_68 a test_struct_68 b, test_struct_66 c )
{ 28 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } ffi_test_66 ] unit-test
: callback-14 ( -- callback )
ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl
[| a b c d e |
a b + c +
d [ mem1>> + ] [ mem2>> + ] bi
e [ mem1>> + ] [ mem2>> + ] bi
] alien-callback ;
: callback-14-test ( a b c d e callback -- result )
ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl alien-indirect ;
{ 28 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } callback-14 [
callback-14-test
] with-callback
] unit-test
{ 44 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 ffi_test_67 ] unit-test
: callback-15 ( -- callback )
ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl
[| a b c d e _f |
a b + c +
d [ mem1>> + ] [ mem2>> + ] bi
e [ mem1>> + ] [ mem2>> + ] bi
_f 2 * +
] alien-callback ;
: callback-15-test ( a b c d e _f callback -- result )
ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl alien-indirect ;
{ 44 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 callback-15 [
callback-15-test
] with-callback
] unit-test
{ 55 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } ffi_test_68
] unit-test
: callback-16 ( -- callback )
ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl
[| a b c d e _f |
a b + c +
d [ mem1>> + ] [ mem2>> + ] bi
e [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
_f [ mem1>> + ] [ mem2>> + ] bi
] alien-callback ;
: callback-16-test ( a b c d e _f callback -- result )
ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl alien-indirect ;
{ 55 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } callback-16 [
callback-16-test
] with-callback
] unit-test
{ 55 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
] unit-test
: callback-17 ( -- callback )
ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl
[| a b c d e _f |
a b + c +
d [ mem1>> + ] [ mem2>> + ] bi
e [ mem1>> >integer + ] [ mem2>> + ] [ mem3>> + ] tri
_f [ mem1>> + ] [ mem2>> + ] bi
] alien-callback ;
: callback-17-test ( a b c d e _f callback -- result )
ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl alien-indirect ;
{ 55 } [
1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } callback-17 [
callback-17-test
] with-callback
] unit-test
{ 36 } [
S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } ffi_test_70
] unit-test
: callback-18 ( -- callback )
ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl
[| a b c |
a [ mem1>> ] [ mem2>> + ] [ mem3>> + ] tri
b [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
c [ mem1>> + ] [ mem2>> + ] bi
] alien-callback ;
: callback-18-test ( a b c callback -- result )
ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl alien-indirect ;
{ 36 } [
S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } callback-18 [
callback-18-test
] with-callback
] unit-test

View File

@ -9,7 +9,7 @@ IN: compiler.tree.escape-analysis.branches
M: #branch escape-analysis* M: #branch escape-analysis*
[ in-d>> add-escaping-values ] [ in-d>> add-escaping-values ]
[ live-children [ [ (escape-analysis) ] when* ] each ] [ live-children sift [ (escape-analysis) ] each ]
bi ; bi ;
: (merge-allocations) ( values -- allocation ) : (merge-allocations) ( values -- allocation )

View File

@ -34,7 +34,7 @@ M: true-constraint satisfied?
TUPLE: false-constraint value ; TUPLE: false-constraint value ;
: =f ( value -- constraint ) resolve-copy false-constraint boa ; : =f ( value -- constriant ) resolve-copy false-constraint boa ;
M: false-constraint assume* M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ] [ \ f <class-info> swap value>> refine-value-info ]

View File

@ -28,17 +28,17 @@ HELP: value-info
{ $description "Gets the value info for the given SSA value. If none is found then a null empty interval is returned." } ; { $description "Gets the value info for the given SSA value. If none is found then a null empty interval is returned." } ;
HELP: value-info<= HELP: value-info<=
{ $values { "info1" value-info-state } { "info2" value-info-state } { "?" boolean } } { $values { "info1" value-info } { "info2" value-info } { "?" boolean } }
{ $description "Checks if the first value info is equal to, or smaller than the second one." } ; { $description "Checks if the first value info is equal to, or smaller than the second one." } ;
HELP: value-info-state HELP: value-info-state
{ $class-description "Represents constraints the compiler knows about the input and output variables to an SSA tree node. It has the following slots:" { $class-description "Represents constraints the compiler knows about the input and output variables to an SSA tree node. It has the following slots:"
{ $slots { $table
{ "class" { "Class of values the variable can take." } } { { $slot "class" } { "Class of values the variable can take." } }
{ "interval" { "Range of values the variable can take." } } { { $slot "interval" } { "Range of values the variable can take." } }
{ "literal" { "Literal value, if present." } } { { $slot "literal" } { "Literal value, if present." } }
{ "literal?" { "Whether the value of the variable is known at compile-time or not." } } { { $slot "literal?" } { "Whether the value of the variable is known at compile-time or not." } }
{ "slots" { "If the value is a literal tuple or fixed length type, then slots is a " { $link sequence } " of " { $link value-info-state } " encoding what is known about its slots at compile-time." } } { { $slot "slots" } { "If the value is a literal tuple or fixed length type, then slots is a " { $link sequence } " of " { $link value-info-state } " encoding what is known about its slots at compile-time." } }
} }
"Don't mutate value infos you receive, always construct new ones. We don't declare the slots read-only to allow cloning followed by writing, and to simplify constructors." "Don't mutate value infos you receive, always construct new ones. We don't declare the slots read-only to allow cloning followed by writing, and to simplify constructors."
} ; } ;

View File

@ -358,7 +358,7 @@ generic-comparison-ops [
\ instance? [ \ instance? [
! We need to force the caller word to recompile when the class ! We need to force the caller word to recompile when the class
! is redefined, since now we're making assumptions about the ! is redefined, since now we're making assumptions but the
! class definition itself. ! class definition itself.
dup literal>> classoid? dup literal>> classoid?
[ [

View File

@ -64,7 +64,7 @@ CONSTANT: vector>vector-intrinsics
CONSTANT: vector-other-intrinsics CONSTANT: vector-other-intrinsics
{ {
(simd-vdot) (simd-v.)
(simd-vsad) (simd-vsad)
(simd-sum) (simd-sum)
(simd-vany?) (simd-vany?)
@ -96,7 +96,7 @@ vector>vector-intrinsics [ { byte-array } "default-output-classes" set-word-prop
\ (simd-sum) [ nip scalar-output-class ] "outputs" set-word-prop \ (simd-sum) [ nip scalar-output-class ] "outputs" set-word-prop
\ (simd-vdot) [ 2nip scalar-output-class ] "outputs" set-word-prop \ (simd-v.) [ 2nip scalar-output-class ] "outputs" set-word-prop
{ {
(simd-vany?) (simd-vany?)

View File

@ -47,6 +47,9 @@ IN: compiler.tree.propagation.slots
[ swap slot <literal-info> ] [ swap slot <literal-info> ]
} 2&& ; } 2&& ;
: length-accessor? ( slot info -- ? )
[ 1 = ] [ length>> ] bi* and ;
: value-info-slot ( slot info -- info' ) : value-info-slot ( slot info -- info' )
{ {
{ [ over 0 = ] [ 2drop fixnum <class-info> ] } { [ over 0 = ] [ 2drop fixnum <class-info> ] }

View File

@ -196,8 +196,7 @@ ERROR: bad-partial-eval quot word ;
dup classoid? dup classoid?
[ [
predicate-def predicate-def
! union{ and intersection{ and not{ have useless ! union{ and intersection{ have useless expansions, and recurse infinitely
! expansions, and recurse infinitely
dup { [ length 2 >= ] [ second \ instance? = ] } 1&& [ dup { [ length 2 >= ] [ second \ instance? = ] } 1&& [
drop f drop f
] when ] when

View File

@ -18,13 +18,13 @@ HELP: #alien-callback
HELP: #call HELP: #call
{ $class-description "SSA tree node that calls a word. It has the following slots:" { $class-description "SSA tree node that calls a word. It has the following slots:"
{ $slots { $table
{ "word" { "The " { $link word } " to call." } } { { $slot "word" } { "The " { $link word } " to call." } }
{ "in-d" { "Sequence of input variables to the call. The items are ordered from top to bottom of the stack." } } { { $slot "in-d" } { "Sequence of input variables to the call. The items are ordered from top to bottom of the stack." } }
{ "out-d" { "Output values of the call." } } { { $slot "out-d" } { "Output values of the call." } }
{ "method" { "If the called word is generic and inlined here, then 'method' contains the inlined " { $link quotation } "." } } { { $slot "method" } { "If the called word is generic and inlined here, then 'method' contains the inlined " { $link quotation } "." } }
{ "body" { "If the called word is generic and inlined, then 'body' is a sequence of SSA nodes built from the inlined method." } } { { $slot "body" } { "If the called word is generic and inlined, then 'body' is a sequence of SSA nodes built from the inlined method." } }
{ "info" { "If the called word is generic and inlined, then the info slot contains an assoc of value infos for the body of the inlined generic. It is set during the propagation pass of the optimizer." } } { { $slot "info" } { "If the called word is generic and inlined, then the info slot contains an assoc of value infos for the body of the inlined generic. It is set during the propagation pass of the optimizer." } }
} }
} ; } ;
@ -34,8 +34,8 @@ HELP: #call-recursive
HELP: #declare HELP: #declare
{ $class-description "SSA tree node emitted when " { $link declare } " declarations are encountered. It has the following slots:" { $class-description "SSA tree node emitted when " { $link declare } " declarations are encountered. It has the following slots:"
{ $slots { $table
{ "declaration" { { $link assoc } " that maps values to the types they are declared as." } } { { $slot "declaration" } { { $link assoc } " that maps values to the types they are declared as." } }
} }
} ; } ;
@ -45,8 +45,8 @@ HELP: #enter-recursive
HELP: #if HELP: #if
{ $class-description "SSA tree node that implements conditional branching. It has the following slots:" { $class-description "SSA tree node that implements conditional branching. It has the following slots:"
{ $slots { $table
{ "children" { { $slot "children" }
{ "A two item " { $link sequence } ". The first item holds the instructions executed if the condition is true and the second those that are executed if it is not true." } { "A two item " { $link sequence } ". The first item holds the instructions executed if the condition is true and the second those that are executed if it is not true." }
} }
} }
@ -54,8 +54,8 @@ HELP: #if
HELP: #introduce HELP: #introduce
{ $class-description "SSA tree node that puts an input value from the \"outside\" on the stack. It is used to \"introduce\" data stack parameter whenever they are needed. It has the following slots:" { $class-description "SSA tree node that puts an input value from the \"outside\" on the stack. It is used to \"introduce\" data stack parameter whenever they are needed. It has the following slots:"
{ $slots { $table
{ "out-d" { "Array of values of the parameters being introduced." } } { { $slot "out-d" } { "Array of values of the parameters being introduced." } }
} }
} ; } ;
@ -64,25 +64,25 @@ HELP: #phi
HELP: #push HELP: #push
{ $class-description "SSA tree node that puts a literal value on the stack. It has the following slots:" { $class-description "SSA tree node that puts a literal value on the stack. It has the following slots:"
{ $slots { $table
{ "out-d" { "A one item array containing the " { $link <value> } " of the literal being pushed." } } { { $slot "out-d" } { "A one item array containing the " { $link <value> } " of the literal being pushed." } }
} }
} }
{ $notes "A " { $link quotation } " is also a literal." } ; { $notes "A " { $link quotation } " is also a literal." } ;
HELP: #recursive HELP: #recursive
{ $class-description "Instruction which encodes a loop. It has the following slots:" { $class-description "Instruction which encodes a loop. It has the following slots:"
{ $slots { $table
{ "child" { "A sequence of nodes representing the body of the loop." } } { { $slot "child" } { "A sequence of nodes representing the body of the loop." } }
{ "loop?" { "If " { $link t } ", the recursion is implemented using a jump, otherwise as a call back to the word." } } { { $slot "loop?" } { "If " { $link t } ", the recursion is implemented using a jump, otherwise as a call back to the word." } }
} }
} }
{ $see-also inline-recursive-word } ; { $see-also inline-recursive-word } ;
HELP: #shuffle HELP: #shuffle
{ $class-description "SSA tree node that represents a stack shuffling operation such as " { $link swap } ". It has the following slots:" { $class-description "SSA tree node that represents a stack shuffling operation such as " { $link swap } ". It has the following slots:"
{ $slots { $table
{ "mapping" { "An " { $link assoc } " that shows how the shuffle output values (the keys) correspond to their inputs (the values)." } } { { $slot "mapping" } { "An " { $link assoc } " that shows how the shuffle output values (the keys) correspond to their inputs (the values)." } }
} }
} ; } ;

View File

@ -68,11 +68,11 @@ C: <connection> connection
: send-to-connection ( message connection -- ) : send-to-connection ( message connection -- )
stream>> [ serialize flush ] with-stream* ; stream>> [ serialize flush ] with-stream* ;
M: remote-thread send M: remote-thread send ( message thread -- )
[ id>> 2array ] [ node>> ] [ thread-connections at ] tri [ id>> 2array ] [ node>> ] [ thread-connections at ] tri
[ nip send-to-connection ] [ send-remote-message ] if* ; [ nip send-to-connection ] [ send-remote-message ] if* ;
M: thread (serialize) M: thread (serialize) ( obj -- )
id>> [ local-node get insecure>> ] dip <remote-thread> (serialize) ; id>> [ local-node get insecure>> ] dip <remote-thread> (serialize) ;
: stop-node ( -- ) : stop-node ( -- )

View File

@ -13,7 +13,7 @@ M: thread mailbox-of
[ { mailbox } declare ] [ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send M: thread send ( message thread -- )
mailbox-of mailbox-put ; mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ; inline : my-mailbox ( -- mailbox ) self mailbox-of ; inline

View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.syntax arrays USING: accessors alien.c-types alien.data alien.syntax arrays
assocs cache classes colors combinators core-foundation assocs cache colors combinators core-foundation
core-foundation.attributed-strings core-foundation.strings core-foundation.attributed-strings core-foundation.strings
core-graphics core-graphics.types core-text.fonts destructors core-graphics core-graphics.types core-text.fonts destructors
fonts init kernel locals make math math.functions math.order fonts init kernel locals make math math.functions math.order
@ -34,6 +34,8 @@ FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context )
SYMBOL: retina? SYMBOL: retina?
ERROR: not-a-string object ;
MEMO: make-attributes ( open-font color -- hashtable ) MEMO: make-attributes ( open-font color -- hashtable )
[ [
kCTForegroundColorAttributeName ,, kCTForegroundColorAttributeName ,,
@ -44,7 +46,7 @@ MEMO: make-attributes ( open-font color -- hashtable )
[ [
[ [
dup selection? [ string>> ] when dup selection? [ string>> ] when
string check-instance dup string? [ not-a-string ] unless
] 2dip ] 2dip
make-attributes <CFAttributedString> &CFRelease make-attributes <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString CTLineCreateWithAttributedString
@ -77,7 +79,9 @@ render-loc render-dim ;
compute-height ; compute-height ;
: metrics>dim ( bounds -- dim ) : metrics>dim ( bounds -- dim )
[ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi 2array ; [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
[ ceiling >integer ]
bi@ 2array ;
: fill-background ( context font dim -- ) : fill-background ( context font dim -- )
[ background>> >rgba-components CGContextSetRGBFillColor ] [ background>> >rgba-components CGContextSetRGBFillColor ]
@ -86,7 +90,7 @@ render-loc render-dim ;
: selection-rect ( dim line selection -- rect ) : selection-rect ( dim line selection -- rect )
[let [ start>> ] [ end>> ] [ string>> ] tri :> ( start end string ) [let [ start>> ] [ end>> ] [ string>> ] tri :> ( start end string )
start end [ 0 swap string subseq utf16n encode length 2 /i ] bi@ start end [ 0 swap string subseq utf16n encode length 2 / >integer ] bi@
] ]
[ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi [ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
[ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ; [ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;

View File

@ -524,7 +524,7 @@ HOOK: immediate-bitwise? cpu ( n -- ? )
HOOK: immediate-comparand? cpu ( n -- ? ) HOOK: immediate-comparand? cpu ( n -- ? )
HOOK: immediate-store? cpu ( n -- ? ) HOOK: immediate-store? cpu ( n -- ? )
M: object immediate-comparand? M: object immediate-comparand? ( n -- ? )
{ {
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] } { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
{ [ dup not ] [ drop t ] } { [ dup not ] [ drop t ] }

View File

@ -5,13 +5,13 @@ compiler.cfg.builder.alien.boxing sequences arrays
alien.c-types cpu.architecture cpu.ppc alien.complex ; alien.c-types cpu.architecture cpu.ppc alien.complex ;
IN: cpu.ppc.32.linux IN: cpu.ppc.32.linux
M: linux lr-save 1 cells ; M: linux lr-save ( -- n ) 1 cells ;
M: linux has-toc f ; M: linux has-toc ( -- ? ) f ;
M: linux reserved-area-size 2 cells ; M: linux reserved-area-size ( -- n ) 2 cells ;
M: linux allows-null-dereference f ; M: linux allows-null-dereference ( -- ? ) f ;
M: ppc param-regs M: ppc param-regs
drop { drop {
@ -35,7 +35,7 @@ M: ppc long-long-odd-register? t ;
M: ppc float-right-align-on-stack? f ; M: ppc float-right-align-on-stack? f ;
M: ppc flatten-struct-type M: ppc flatten-struct-type ( type -- seq )
{ {
{ [ dup lookup-c-type complex-double lookup-c-type = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { int-rep f f } { int-rep f f } [ drop { { int-rep f f } { int-rep f f }

View File

@ -7,11 +7,11 @@ IN: cpu.ppc.64.linux
M: linux lr-save 2 cells ; M: linux lr-save 2 cells ;
M: linux has-toc t ; M: linux has-toc ( -- ? ) t ;
M: linux reserved-area-size 6 cells ; M: linux reserved-area-size ( -- n ) 6 cells ;
M: linux allows-null-dereference f ; M: linux allows-null-dereference ( -- ? ) f ;
M: ppc param-regs M: ppc param-regs
drop { drop {
@ -33,7 +33,7 @@ M: ppc long-long-odd-register? f ;
M: ppc float-right-align-on-stack? t ; M: ppc float-right-align-on-stack? t ;
M: ppc flatten-struct-type M: ppc flatten-struct-type ( type -- seq )
{ {
{ [ dup lookup-c-type complex-double lookup-c-type = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] } [ drop { { double-rep f f } { double-rep f f } } ] }
@ -42,7 +42,7 @@ M: ppc flatten-struct-type
[ heap-size cell align cell /i { int-rep f f } <repetition> ] [ heap-size cell align cell /i { int-rep f f } <repetition> ]
} cond ; } cond ;
M: ppc flatten-struct-type-return M: ppc flatten-struct-type-return ( type -- seq )
{ {
{ [ dup lookup-c-type complex-double lookup-c-type = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] } [ drop { { double-rep f f } { double-rep f f } } ] }

View File

@ -115,16 +115,16 @@ IN: cpu.ppc.assembler
! 2.4 Branch Instructions ! 2.4 Branch Instructions
GENERIC: B ( target_addr/label -- ) GENERIC: B ( target_addr/label -- )
M: integer B -2 shift 0 0 18 i-insn ; M: integer B ( target_addr -- ) -2 shift 0 0 18 i-insn ;
GENERIC: BL ( target_addr/label -- ) GENERIC: BL ( target_addr/label -- )
M: integer BL -2 shift 0 1 18 i-insn ; M: integer BL ( target_addr -- ) -2 shift 0 1 18 i-insn ;
: BA ( target_addr -- ) -2 shift 1 0 18 i-insn ; : BA ( target_addr -- ) -2 shift 1 0 18 i-insn ;
: BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ; : BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ;
GENERIC: BC ( bo bi target_addr/label -- ) GENERIC: BC ( bo bi target_addr/label -- )
M: integer BC -2 shift 0 0 16 b-insn ; M: integer BC ( bo bi target_addr -- ) -2 shift 0 0 16 b-insn ;
: BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ; : BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ;
: BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ; : BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ;

View File

@ -34,9 +34,9 @@ HOOK: has-toc os ( -- ? )
HOOK: reserved-area-size os ( -- n ) HOOK: reserved-area-size os ( -- n )
HOOK: allows-null-dereference os ( -- ? ) HOOK: allows-null-dereference os ( -- ? )
M: label B [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ; M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BL [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ; M: label BL ( label -- ) [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BC [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ; M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
CONSTANT: scratch-reg 30 CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30 CONSTANT: fp-scratch-reg 30
@ -44,16 +44,16 @@ CONSTANT: ds-reg 14
CONSTANT: rs-reg 15 CONSTANT: rs-reg 15
CONSTANT: vm-reg 16 CONSTANT: vm-reg 16
M: ppc machine-registers M: ppc machine-registers ( -- assoc )
{ {
{ int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] } { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
{ float-regs $[ 0 29 [a,b] ] } { float-regs $[ 0 29 [a,b] ] }
} ; } ;
M: ppc frame-reg 31 ; M: ppc frame-reg ( -- reg ) 31 ;
M: ppc.32 vm-stack-space 16 ; M: ppc.32 vm-stack-space ( -- n ) 16 ;
M: ppc.64 vm-stack-space 32 ; M: ppc.64 vm-stack-space ( -- n ) 32 ;
M: ppc complex-addressing? f ; M: ppc complex-addressing? ( -- ? ) f ;
! PW1-PW8 parameter save slots ! PW1-PW8 parameter save slots
: param-save-size ( -- n ) 8 cells ; foldable : param-save-size ( -- n ) 8 cells ; foldable
@ -67,7 +67,7 @@ M: ppc complex-addressing? f ;
: param@ ( n -- offset ) : param@ ( n -- offset )
reserved-area-size + ; reserved-area-size + ;
M: ppc gc-root-offset M: ppc gc-root-offset ( spill-slot -- n )
n>> spill@ cell /i ; n>> spill@ cell /i ;
: LOAD32 ( r n -- ) : LOAD32 ( r n -- )
@ -129,12 +129,12 @@ HOOK: %load-cell-imm-rc cpu ( -- rel-class )
M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ; M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ; M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ;
M: ppc.32 %load-immediate M: ppc.32 %load-immediate ( reg val -- )
dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ; dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
M: ppc.64 %load-immediate M: ppc.64 %load-immediate ( reg val -- )
dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ; dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
M: ppc %load-reference M: ppc %load-reference ( reg obj -- )
[ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ] [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
[ \ f type-number LI ] [ \ f type-number LI ]
if* ; if* ;
@ -156,11 +156,11 @@ M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ; M: rs-loc loc-reg drop rs-reg ;
! Load value at stack location loc into vreg. ! Load value at stack location loc into vreg.
M: ppc %peek M: ppc %peek ( vreg loc -- )
[ loc-reg ] [ n>> cells neg ] bi %load-cell ; [ loc-reg ] [ n>> cells neg ] bi %load-cell ;
! Replace value at stack location loc with value in vreg. ! Replace value at stack location loc with value in vreg.
M: ppc %replace M: ppc %replace ( vreg loc -- )
[ loc-reg ] [ n>> cells neg ] bi %store-cell ; [ loc-reg ] [ n>> cells neg ] bi %store-cell ;
! Replace value at stack location with an immediate value. ! Replace value at stack location with an immediate value.
@ -176,45 +176,45 @@ M:: ppc %replace-imm ( src loc -- )
} cond } cond
scratch-reg reg offset %store-cell ; scratch-reg reg offset %store-cell ;
M: ppc %clear M: ppc %clear ( loc -- )
297 swap %replace-imm ; 297 swap %replace-imm ;
! Increment stack pointer by n cells. ! Increment stack pointer by n cells.
M: ppc %inc M: ppc %inc ( loc -- )
[ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ; [ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ;
M: ppc stack-frame-size M: ppc stack-frame-size ( stack-frame -- i )
(stack-frame-size) (stack-frame-size)
reserved-area-size + reserved-area-size +
param-save-size + param-save-size +
factor-area-size + factor-area-size +
16 align ; 16 align ;
M: ppc %call M: ppc %call ( word -- )
0 BL rc-relative-ppc-3-pc rel-word-pic ; 0 BL rc-relative-ppc-3-pc rel-word-pic ;
: instrs ( n -- b ) 4 * ; inline : instrs ( n -- b ) 4 * ; inline
M: ppc %jump M: ppc %jump ( word -- )
6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here 6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
0 B rc-relative-ppc-3-pc rel-word-pic-tail ; 0 B rc-relative-ppc-3-pc rel-word-pic-tail ;
M: ppc %dispatch M: ppc %dispatch ( src temp -- )
[ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ] [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
[ swap dupd %load-cell-x ] [ swap dupd %load-cell-x ]
[ nip MTCTR ] 2tri BCTR ; [ nip MTCTR ] 2tri BCTR ;
M: ppc %slot M: ppc %slot ( dst obj slot scale tag -- )
[ 0 assert= ] bi@ %load-cell-x ; [ 0 assert= ] bi@ %load-cell-x ;
M: ppc %slot-imm M: ppc %slot-imm ( dst obj slot tag -- )
slot-offset scratch-reg swap LI slot-offset scratch-reg swap LI
scratch-reg %load-cell-x ; scratch-reg %load-cell-x ;
M: ppc %set-slot M: ppc %set-slot ( src obj slot scale tag -- )
[ 0 assert= ] bi@ %store-cell-x ; [ 0 assert= ] bi@ %store-cell-x ;
M: ppc %set-slot-imm M: ppc %set-slot-imm ( src obj slot tag -- )
slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ; slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
M: ppc %jump-label B ; M: ppc %jump-label B ;
@ -255,7 +255,7 @@ M: ppc.64 %log2 [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
M: ppc.32 %bit-count POPCNTW ; M: ppc.32 %bit-count POPCNTW ;
M: ppc.64 %bit-count POPCNTD ; M: ppc.64 %bit-count POPCNTD ;
M: ppc %copy M: ppc %copy ( dst src rep -- )
2over eq? [ 3drop ] [ 2over eq? [ 3drop ] [
{ {
{ tagged-rep [ MR ] } { tagged-rep [ MR ] }
@ -276,15 +276,15 @@ M: ppc %copy
{ cc/o [ 0 label BNS ] } { cc/o [ 0 label BNS ] }
} case ; inline } case ; inline
M: ppc %fixnum-add M: ppc %fixnum-add ( label dst src1 src2 cc -- )
[ ADDO. ] overflow-template ; [ ADDO. ] overflow-template ;
M: ppc %fixnum-sub M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
[ SUBFO. ] overflow-template ; [ SUBFO. ] overflow-template ;
M: ppc.32 %fixnum-mul M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLWO. ] overflow-template ; [ MULLWO. ] overflow-template ;
M: ppc.64 %fixnum-mul M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLDO. ] overflow-template ; [ MULLDO. ] overflow-template ;
M: ppc %add-float FADD ; M: ppc %add-float FADD ;
@ -292,11 +292,11 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ; M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ; M: ppc %div-float FDIV ;
M: ppc %min-float M: ppc %min-float ( dst src1 src2 -- )
2dup [ scratch-reg ] 2dip FSUB 2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ; [ scratch-reg ] 2dip FSEL ;
M: ppc %max-float M: ppc %max-float ( dst src1 src2 -- )
2dup [ scratch-reg ] 2dip FSUB 2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ; [ scratch-reg ] 2dip FSEL ;
@ -343,26 +343,26 @@ M:: ppc.64 %float>integer ( dst src -- )
} ; } ;
! Return values of this class go here ! Return values of this class go here
M: ppc return-regs M: ppc return-regs ( -- regs )
{ {
{ int-regs { 3 4 5 6 } } { int-regs { 3 4 5 6 } }
{ float-regs { 1 2 3 4 } } { float-regs { 1 2 3 4 } }
} ; } ;
! Is this structure small enough to be returned in registers? ! Is this structure small enough to be returned in registers?
M: ppc return-struct-in-registers? M: ppc return-struct-in-registers? ( c-type -- ? )
lookup-c-type return-in-registers?>> ; lookup-c-type return-in-registers?>> ;
! If t, the struct return pointer is never passed in a param reg ! If t, the struct return pointer is never passed in a param reg
M: ppc struct-return-on-stack? f ; M: ppc struct-return-on-stack? ( -- ? ) f ;
GENERIC: load-param ( reg src -- ) GENERIC: load-param ( reg src -- )
M: integer load-param int-rep %copy ; M: integer load-param ( reg src -- ) int-rep %copy ;
M: spill-slot load-param [ 1 ] dip n>> spill@ %load-cell ; M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;
GENERIC: store-param ( reg dst -- ) GENERIC: store-param ( reg dst -- )
M: integer store-param swap int-rep %copy ; M: integer store-param ( reg dst -- ) swap int-rep %copy ;
M: spill-slot store-param [ 1 ] dip n>> spill@ %store-cell ; M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;
M:: ppc %unbox ( dst src func rep -- ) M:: ppc %unbox ( dst src func rep -- )
3 src load-param 3 src load-param
@ -459,7 +459,10 @@ M:: ppc %c-invoke ( name dll gc-map -- )
dead-outputs [ first2 discard-reg-param ] each dead-outputs [ first2 discard-reg-param ] each
; inline ; inline
M: ppc %alien-invoke M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs
reg-outputs dead-outputs
cleanup stack-size
symbols dll gc-map -- )
'[ _ _ _ %c-invoke ] emit-alien-insn ; '[ _ _ _ %c-invoke ] emit-alien-insn ;
M:: ppc %alien-indirect ( src M:: ppc %alien-indirect ( src
@ -480,33 +483,36 @@ M:: ppc %alien-indirect ( src
gc-map gc-map-here gc-map gc-map-here
] emit-alien-insn ; ] emit-alien-insn ;
M: ppc %alien-assembly M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs
reg-outputs dead-outputs
cleanup stack-size
quot -- )
'[ _ call( -- ) ] emit-alien-insn ; '[ _ call( -- ) ] emit-alien-insn ;
M: ppc %callback-inputs M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
[ [ first3 load-reg-param ] each ] [ [ first3 load-reg-param ] each ]
[ [ first3 load-stack-param ] each ] bi* [ [ first3 load-stack-param ] each ] bi*
3 vm-reg MR 3 vm-reg MR
4 0 LI 4 0 LI
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: ppc %callback-outputs M: ppc %callback-outputs ( reg-inputs -- )
3 vm-reg MR 3 vm-reg MR
"end_callback" f f %c-invoke "end_callback" f f %c-invoke
[ first3 store-reg-param ] each ; [ first3 store-reg-param ] each ;
M: ppc stack-cleanup M: ppc stack-cleanup ( stack-size return abi -- n )
3drop 0 ; 3drop 0 ;
M: ppc fused-unboxing? f ; M: ppc fused-unboxing? f ;
M: ppc %alien-global M: ppc %alien-global ( register symbol dll -- )
[ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ; [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
M: ppc %vm-field [ vm-reg ] dip %load-cell ; M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ;
M: ppc %set-vm-field [ vm-reg ] dip %store-cell ; M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;
M: ppc %unbox-alien M: ppc %unbox-alien ( dst src -- )
scratch-reg alien-offset LI scratch-reg %load-cell-x ; scratch-reg alien-offset LI scratch-reg %load-cell-x ;
! Convert a c-ptr object to a raw C pointer. ! Convert a c-ptr object to a raw C pointer.
@ -700,7 +706,7 @@ M:: ppc.64 %convert-integer ( dst src c-type -- )
{ c:ulonglong [ ] } { c:ulonglong [ ] }
} case ; } case ;
M: ppc.32 %load-memory-imm M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
[ [
pick %trap-null pick %trap-null
{ {
@ -719,7 +725,7 @@ M: ppc.32 %load-memory-imm
} case } case
] ?if ; ] ?if ;
M: ppc.64 %load-memory-imm M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
[ [
pick %trap-null pick %trap-null
{ {
@ -741,7 +747,7 @@ M: ppc.64 %load-memory-imm
] ?if ; ] ?if ;
M: ppc.32 %load-memory M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
pick %trap-null pick %trap-null
@ -761,7 +767,7 @@ M: ppc.32 %load-memory
} case } case
] ?if ; ] ?if ;
M: ppc.64 %load-memory M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
pick %trap-null pick %trap-null
@ -784,7 +790,7 @@ M: ppc.64 %load-memory
] ?if ; ] ?if ;
M: ppc.32 %store-memory-imm M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
[ [
{ {
{ c:char [ STB ] } { c:char [ STB ] }
@ -802,7 +808,7 @@ M: ppc.32 %store-memory-imm
} case } case
] ?if ; ] ?if ;
M: ppc.64 %store-memory-imm M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
[ [
{ {
{ c:char [ STB ] } { c:char [ STB ] }
@ -822,7 +828,7 @@ M: ppc.64 %store-memory-imm
} case } case
] ?if ; ] ?if ;
M: ppc.32 %store-memory M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
{ {
@ -841,7 +847,7 @@ M: ppc.32 %store-memory
} case } case
] ?if ; ] ?if ;
M: ppc.64 %store-memory M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
{ {
@ -908,7 +914,7 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
{ cc/<= [ 0 label BGT ] } { cc/<= [ 0 label BGT ] }
} case ; } case ;
M: ppc %call-gc M: ppc %call-gc ( gc-map -- )
\ minor-gc %call gc-map-here ; \ minor-gc %call gc-map-here ;
M:: ppc %prologue ( stack-size -- ) M:: ppc %prologue ( stack-size -- )
@ -1027,7 +1033,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ; label branch1 branch2 (%branch) ;
M: ppc %spill M: ppc %spill ( src rep dst -- )
n>> spill@ swap { n>> spill@ swap {
{ int-rep [ [ 1 ] dip %store-cell ] } { int-rep [ [ 1 ] dip %store-cell ] }
{ tagged-rep [ [ 1 ] dip %store-cell ] } { tagged-rep [ [ 1 ] dip %store-cell ] }
@ -1037,7 +1043,7 @@ M: ppc %spill
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] } { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ; } case ;
M: ppc %reload M: ppc %reload ( dst rep src -- )
n>> spill@ swap { n>> spill@ swap {
{ int-rep [ [ 1 ] dip %load-cell ] } { int-rep [ [ 1 ] dip %load-cell ] }
{ tagged-rep [ [ 1 ] dip %load-cell ] } { tagged-rep [ [ 1 ] dip %load-cell ] }
@ -1047,11 +1053,11 @@ M: ppc %reload
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] } { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
} case ; } case ;
M: ppc immediate-arithmetic? -32768 32767 between? ; M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? 0 65535 between? ; M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
M: ppc immediate-store? immediate-comparand? ; M: ppc immediate-store? ( n -- ? ) immediate-comparand? ;
M: ppc enable-cpu-features M: ppc enable-cpu-features ( -- )
enable-float-intrinsics ; enable-float-intrinsics ;
USE: vocabs USE: vocabs

View File

@ -26,18 +26,18 @@ M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ; M: x86.32 frame-reg EBP ;
M: x86.32 immediate-comparand? drop t ; M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M:: x86.32 %load-vector ( dst val rep -- ) M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ; dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
M: x86.32 %vm-field M: x86.32 %vm-field ( dst field -- )
[ 0 [] MOV ] dip rc-absolute-cell rel-vm ; [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %set-vm-field M: x86.32 %set-vm-field ( dst field -- )
[ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ; [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip rc-absolute-cell rel-vm ; [ 0 MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %mark-card M: x86.32 %mark-card
@ -61,7 +61,7 @@ M: x86.32 vm-stack-space 16 ;
: save-vm-ptr ( n -- ) : save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ; stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 return-struct-in-registers? M: x86.32 return-struct-in-registers? ( c-type -- ? )
lookup-c-type lookup-c-type
[ return-in-registers?>> ] [ return-in-registers?>> ]
[ heap-size { 1 2 4 8 } member? ] bi [ heap-size { 1 2 4 8 } member? ] bi
@ -87,7 +87,7 @@ M: x86.32 return-regs
M: x86.32 %prepare-jump M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
M: x86.32 %load-stack-param M: x86.32 %load-stack-param ( dst rep n -- )
next-stack@ swap pick register? [ %copy ] [ next-stack@ swap pick register? [ %copy ] [
{ {
{ int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] }
@ -96,7 +96,7 @@ M: x86.32 %load-stack-param
} case } case
] if ; ] if ;
M: x86.32 %store-stack-param M: x86.32 %store-stack-param ( src rep n -- )
stack@ swap pick register? [ swapd %copy ] [ stack@ swap pick register? [ swapd %copy ] [
{ {
{ int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] }
@ -115,7 +115,7 @@ M: x86.32 %store-stack-param
dst ?spill-slot x87-insn execute dst ?spill-slot x87-insn execute
] if ; inline ] if ; inline
M: x86.32 %load-reg-param M: x86.32 %load-reg-param ( vreg rep reg -- )
swap { swap {
{ int-rep [ int-rep %copy ] } { int-rep [ int-rep %copy ] }
{ float-rep [ drop \ FSTPS float-rep load-float-return ] } { float-rep [ drop \ FSTPS float-rep load-float-return ] }
@ -132,14 +132,14 @@ M: x86.32 %load-reg-param
src ?spill-slot x87-insn execute src ?spill-slot x87-insn execute
] if ; inline ] if ; inline
M: x86.32 %store-reg-param M: x86.32 %store-reg-param ( vreg rep reg -- )
swap { swap {
{ int-rep [ swap int-rep %copy ] } { int-rep [ swap int-rep %copy ] }
{ float-rep [ drop \ FLDS float-rep store-float-return ] } { float-rep [ drop \ FLDS float-rep store-float-return ] }
{ double-rep [ drop \ FLDL double-rep store-float-return ] } { double-rep [ drop \ FLDL double-rep store-float-return ] }
} case ; } case ;
M: x86.32 %discard-reg-param M: x86.32 %discard-reg-param ( rep reg -- )
drop { drop {
{ int-rep [ ] } { int-rep [ ] }
{ float-rep [ ST0 FSTP ] } { float-rep [ ST0 FSTP ] }
@ -179,12 +179,12 @@ M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
M: x86.32 %c-invoke M: x86.32 %c-invoke
[ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback M: x86.32 %begin-callback ( -- )
0 save-vm-ptr 0 save-vm-ptr
4 stack@ 0 MOV 4 stack@ 0 MOV
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: x86.32 %end-callback M: x86.32 %end-callback ( -- )
0 save-vm-ptr 0 save-vm-ptr
"end_callback" f f %c-invoke ; "end_callback" f f %c-invoke ;
@ -192,7 +192,7 @@ M: x86.32 %end-callback
! MINGW ABI incompatibility disaster ! MINGW ABI incompatibility disaster
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
M: x86.32 %prepare-var-args drop ; M: x86.32 %prepare-var-args ( reg-inputs -- ) drop ;
M:: x86.32 stack-cleanup ( stack-size return abi -- n ) M:: x86.32 stack-cleanup ( stack-size return abi -- n )
! a) Functions which are stdcall/fastcall/thiscall have to ! a) Functions which are stdcall/fastcall/thiscall have to
@ -205,7 +205,7 @@ M:: x86.32 stack-cleanup ( stack-size return abi -- n )
[ 0 ] [ 0 ]
} cond ; } cond ;
M: x86.32 %cleanup M: x86.32 %cleanup ( n -- )
[ ESP swap SUB ] unless-zero ; [ ESP swap SUB ] unless-zero ;
M: x86.32 %safepoint M: x86.32 %safepoint
@ -224,7 +224,7 @@ M: x86.32 flatten-struct-type
M: x86.32 struct-return-on-stack? os linux? not ; M: x86.32 struct-return-on-stack? os linux? not ;
M: x86.32 (cpuid) M: x86.32 (cpuid) ( eax ecx regs -- )
void { uint uint void* } cdecl [ void { uint uint void* } cdecl [
! Save ds-reg, rs-reg ! Save ds-reg, rs-reg
EDI PUSH EDI PUSH

View File

@ -40,16 +40,16 @@ M: x86.64 machine-registers
: vm-reg ( -- reg ) R13 ; inline : vm-reg ( -- reg ) R13 ; inline
: nv-reg ( -- reg ) RBX ; inline : nv-reg ( -- reg ) RBX ; inline
M: x86.64 %vm-field M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ; [ vm-reg ] dip [+] MOV ;
M:: x86.64 %load-vector ( dst val rep -- ) M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ; dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
M: x86.64 %set-vm-field M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ; [ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ; [ vm-reg ] dip [+] LEA ;
M: x86.64 %prepare-jump M: x86.64 %prepare-jump
@ -83,7 +83,7 @@ M:: x86.64 %load-reg-param ( vreg rep reg -- )
M:: x86.64 %store-reg-param ( vreg rep reg -- ) M:: x86.64 %store-reg-param ( vreg rep reg -- )
reg vreg rep %copy ; reg vreg rep %copy ;
M: x86.64 %discard-reg-param M: x86.64 %discard-reg-param ( rep reg -- )
2drop ; 2drop ;
M:: x86.64 %unbox ( dst src func rep -- ) M:: x86.64 %unbox ( dst src func rep -- )
@ -102,12 +102,12 @@ M: x86.64 %c-invoke
[ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
gc-map-here ; gc-map-here ;
M: x86.64 %begin-callback M: x86.64 %begin-callback ( -- )
param-reg-0 vm-reg MOV param-reg-0 vm-reg MOV
param-reg-1 0 MOV param-reg-1 0 MOV
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: x86.64 %end-callback M: x86.64 %end-callback ( -- )
param-reg-0 vm-reg MOV param-reg-0 vm-reg MOV
"end_callback" f f %c-invoke ; "end_callback" f f %c-invoke ;
@ -122,7 +122,7 @@ M: x86.64 long-long-on-stack? f ;
M: x86.64 struct-return-on-stack? f ; M: x86.64 struct-return-on-stack? f ;
M: x86.64 (cpuid) M: x86.64 (cpuid) ( rax rcx regs -- )
void { uint uint void* } cdecl [ void { uint uint void* } cdecl [
RAX param-reg-0 MOV RAX param-reg-0 MOV
RCX param-reg-1 MOV RCX param-reg-1 MOV

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs USING: accessors alien.c-types arrays assocs
compiler.cfg.builder.alien.boxing cpu.architecture cpu.x86 compiler.cfg.builder.alien.boxing cpu.architecture cpu.x86
cpu.x86.assembler cpu.x86.assembler.operands kernel layouts locals cpu.x86.assembler cpu.x86.assembler.operands kernel layouts make math
make math math.order namespaces sequences splitting system ; math.order sequences splitting system ;
IN: cpu.x86.64.unix IN: cpu.x86.64.unix
M: x86.64 param-regs M: x86.64 param-regs
@ -24,28 +24,18 @@ M: x86.64 reserved-stack-space 0 ;
[ 8 mod zero? [ t , ] when , ] assoc-each [ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ; ] { } make { t } split harvest ;
:: flatten-small-struct ( c-type -- seq ) : flatten-small-struct ( c-type -- seq )
c-type struct-types&offset split-struct [ struct-types&offset split-struct [
[ lookup-c-type c-type-rep reg-class-of ] map [ lookup-c-type c-type-rep reg-class-of ] map
int-regs swap member? int-rep double-rep ? int-regs swap member? int-rep double-rep ?
f f 3array f f 3array
] map :> reps ] map ;
int-reg-reps get float-reg-reps get and [
reps reg-reps :> ( int-mems float-mems )
int-reg-reps get int-mems + 6 >
float-reg-reps get float-mems + 8 > or [
reps [ first t f 3array ] map
] [ reps ] if
] [ reps ] if ;
M: x86.64 flatten-struct-type M: x86.64 flatten-struct-type ( c-type -- seq )
dup heap-size 16 <= dup heap-size 16 <=
[ flatten-small-struct record-reg-reps ] [ [ flatten-small-struct ] [ call-next-method [ first t f 3array ] map ] if ;
call-next-method unrecord-reg-reps
[ first t f 3array ] map
] if ;
M: x86.64 return-struct-in-registers? M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ; heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ; M: x86.64 dummy-stack-params? f ;
@ -54,6 +44,6 @@ M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ; M: x86.64 dummy-fp-params? f ;
M: x86.64 %prepare-var-args M: x86.64 %prepare-var-args ( reg-inputs -- )
[ second reg-class-of float-regs? ] count 8 min [ second reg-class-of float-regs? ] count 8 min
[ EAX EAX XOR ] [ <byte> AL swap MOV ] if-zero ; [ EAX EAX XOR ] [ <byte> AL swap MOV ] if-zero ;

View File

@ -13,7 +13,7 @@ M: x86.64 param-regs
M: x86.64 reserved-stack-space 4 cells ; M: x86.64 reserved-stack-space 4 cells ;
M: x86.64 return-struct-in-registers? M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size { 1 2 4 8 } member? ; heap-size { 1 2 4 8 } member? ;
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
@ -24,4 +24,5 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ; M: x86.64 dummy-fp-params? t ;
M: x86.64 %prepare-var-args drop ; M: x86.64 %prepare-var-args ( reg-inputs -- )
drop ;

View File

@ -338,7 +338,7 @@ M: immediate SBB { 0b011 t 0x80 } immediate-1/4 ;
M: operand SBB 0o030 2-operand ; M: operand SBB 0o030 2-operand ;
GENERIC: AND ( dst src -- ) GENERIC: AND ( dst src -- )
M: immediate AND M: immediate AND ( dst src -- )
maybe-zero-extend { 0b100 t 0x80 } immediate-1/4 ; maybe-zero-extend { 0b100 t 0x80 } immediate-1/4 ;
M: operand AND 0o040 2-operand ; M: operand AND 0o040 2-operand ;
@ -357,11 +357,13 @@ M: immediate XOR { 0b110 t 0x80 } immediate-1/4 ;
M: operand XOR 0o060 2-operand ; M: operand XOR 0o060 2-operand ;
GENERIC: CMP ( dst src -- ) GENERIC: CMP ( dst src -- )
M: immediate CMP { 0b111 t 0x80 } immediate-1/4 ; M: immediate CMP ( dst src -- )
{ 0b111 t 0x80 } immediate-1/4 ;
M: operand CMP 0o070 2-operand ; M: operand CMP 0o070 2-operand ;
GENERIC: TEST ( dst src -- ) GENERIC: TEST ( dst src -- )
M: immediate TEST maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ; M: immediate TEST ( dst src -- )
maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ;
M: operand TEST 0o204 2-operand ; M: operand TEST 0o204 2-operand ;
: XCHG ( dst src -- ) 0o207 2-operand ; : XCHG ( dst src -- ) 0o207 2-operand ;
@ -369,20 +371,20 @@ M: operand TEST 0o204 2-operand ;
: BSR ( dst src -- ) { 0x0f 0xbd } (2-operand) ; : BSR ( dst src -- ) { 0x0f 0xbd } (2-operand) ;
GENERIC: BT ( value n -- ) GENERIC: BT ( value n -- )
M: immediate BT { 0b100 t { 0x0f 0xba } } immediate-1* ; M: immediate BT ( value n -- ) { 0b100 t { 0x0f 0xba } } immediate-1* ;
M: operand BT swap { 0x0f 0xa3 } (2-operand) ; M: operand BT ( value n -- ) swap { 0x0f 0xa3 } (2-operand) ;
GENERIC: BTC ( value n -- ) GENERIC: BTC ( value n -- )
M: immediate BTC { 0b111 t { 0x0f 0xba } } immediate-1* ; M: immediate BTC ( value n -- ) { 0b111 t { 0x0f 0xba } } immediate-1* ;
M: operand BTC swap { 0x0f 0xbb } (2-operand) ; M: operand BTC ( value n -- ) swap { 0x0f 0xbb } (2-operand) ;
GENERIC: BTR ( value n -- ) GENERIC: BTR ( value n -- )
M: immediate BTR { 0b110 t { 0x0f 0xba } } immediate-1* ; M: immediate BTR ( value n -- ) { 0b110 t { 0x0f 0xba } } immediate-1* ;
M: operand BTR swap { 0x0f 0xb3 } (2-operand) ; M: operand BTR ( value n -- ) swap { 0x0f 0xb3 } (2-operand) ;
GENERIC: BTS ( value n -- ) GENERIC: BTS ( value n -- )
M: immediate BTS { 0b101 t { 0x0f 0xba } } immediate-1* ; M: immediate BTS ( value n -- ) { 0b101 t { 0x0f 0xba } } immediate-1* ;
M: operand BTS swap { 0x0f 0xab } (2-operand) ; M: operand BTS ( value n -- ) swap { 0x0f 0xab } (2-operand) ;
: NOT ( dst -- ) { 0b010 t 0xf7 } 1-operand ; : NOT ( dst -- ) { 0b010 t 0xf7 } 1-operand ;
: NEG ( dst -- ) { 0b011 t 0xf7 } 1-operand ; : NEG ( dst -- ) { 0b011 t 0xf7 } 1-operand ;

View File

@ -3,9 +3,9 @@ IN: cpu.x86.assembler.operands
HELP: indirect HELP: indirect
{ $class-description "Tuple that represents an indirect addressing operand. It has the following slots:" { $class-description "Tuple that represents an indirect addressing operand. It has the following slots:"
{ $slots { $table
{ "index" { "Register for the index value. It must not be " { $link ESP } " or " { $link RSP } "." } } { { $slot "index" } { "Register for the index value. It must not be " { $link ESP } " or " { $link RSP } "." } }
{ "displacement" { "An integer offset." } } { { $slot "displacement" } { "An integer offset." } }
} }
} ; } ;

View File

@ -35,16 +35,16 @@ M: x86 integer-float-needs-stack-frame? f ;
M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ; M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
M: x86 %float>integer CVTTSD2SI ; M: x86 %float>integer CVTTSD2SI ;
M: x86 %compare-float-ordered M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
[ COMISD ] (%compare-float) ; [ COMISD ] (%compare-float) ;
M: x86 %compare-float-unordered M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
[ UCOMISD ] (%compare-float) ; [ UCOMISD ] (%compare-float) ;
M: x86 %compare-float-ordered-branch M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
[ COMISD ] (%compare-float-branch) ; [ COMISD ] (%compare-float-branch) ;
M: x86 %compare-float-unordered-branch M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
[ UCOMISD ] (%compare-float-branch) ; [ UCOMISD ] (%compare-float-branch) ;
! SIMD ! SIMD
@ -262,7 +262,7 @@ M: x86 %shuffle-vector-halves-imm-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %shuffle-vector M: x86 %shuffle-vector ( dst src shuffle rep -- )
two-operand PSHUFB ; two-operand PSHUFB ;
M: x86 %shuffle-vector-reps M: x86 %shuffle-vector-reps
@ -331,14 +331,14 @@ M: x86 %unsigned-pack-vector-reps
{ sse4.1? { int-4-rep } } { sse4.1? { int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %tail>head-vector M: x86 %tail>head-vector ( dst src rep -- )
dup { dup {
{ float-4-rep [ drop UNPCKHPD ] } { float-4-rep [ drop UNPCKHPD ] }
{ double-2-rep [ drop UNPCKHPD ] } { double-2-rep [ drop UNPCKHPD ] }
[ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ] [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
} case ; } case ;
M: x86 %unpack-vector-head M: x86 %unpack-vector-head ( dst src rep -- )
{ {
{ char-16-rep [ PMOVSXBW ] } { char-16-rep [ PMOVSXBW ] }
{ uchar-16-rep [ PMOVZXBW ] } { uchar-16-rep [ PMOVZXBW ] }
@ -349,13 +349,13 @@ M: x86 %unpack-vector-head
{ float-4-rep [ CVTPS2PD ] } { float-4-rep [ CVTPS2PD ] }
} case ; } case ;
M: x86 %unpack-vector-head-reps M: x86 %unpack-vector-head-reps ( -- reps )
{ {
{ sse2? { float-4-rep } } { sse2? { float-4-rep } }
{ sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } } { sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %integer>float-vector M: x86 %integer>float-vector ( dst src rep -- )
{ {
{ int-4-rep [ CVTDQ2PS ] } { int-4-rep [ CVTDQ2PS ] }
} case ; } case ;
@ -365,7 +365,7 @@ M: x86 %integer>float-vector-reps
{ sse2? { int-4-rep } } { sse2? { int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %float>integer-vector M: x86 %float>integer-vector ( dst src rep -- )
{ {
{ float-4-rep [ CVTTPS2DQ ] } { float-4-rep [ CVTTPS2DQ ] }
} case ; } case ;
@ -405,7 +405,7 @@ M: x86 %float>integer-vector-reps
{ cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] } { cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] }
} case ; } case ;
M: x86 %compare-vector M: x86 %compare-vector ( dst src1 src2 rep cc -- )
[ [ two-operand ] keep ] dip [ [ two-operand ] keep ] dip
over float-vector-rep? over float-vector-rep?
[ %compare-float-vector ] [ %compare-float-vector ]
@ -481,7 +481,7 @@ M: x86 %compare-vector-ccs
[ drop PMOVMSKB 0xffff ] [ drop PMOVMSKB 0xffff ]
} case ; } case ;
M: x86 %move-vector-mask M: x86 %move-vector-mask ( dst src rep -- )
(%move-vector-mask) drop ; (%move-vector-mask) drop ;
M: x86 %move-vector-mask-reps M: x86 %move-vector-mask-reps
@ -512,7 +512,7 @@ M: x86 %test-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %add-vector M: x86 %add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ADDPS ] } { float-4-rep [ ADDPS ] }
@ -533,7 +533,7 @@ M: x86 %add-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %saturated-add-vector M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PADDSB ] } { char-16-rep [ PADDSB ] }
@ -547,7 +547,7 @@ M: x86 %saturated-add-vector-reps
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %add-sub-vector M: x86 %add-sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ADDSUBPS ] } { float-4-rep [ ADDSUBPS ] }
@ -559,7 +559,7 @@ M: x86 %add-sub-vector-reps
{ sse3? { float-4-rep double-2-rep } } { sse3? { float-4-rep double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %sub-vector M: x86 %sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ SUBPS ] } { float-4-rep [ SUBPS ] }
@ -580,7 +580,7 @@ M: x86 %sub-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %saturated-sub-vector M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PSUBSB ] } { char-16-rep [ PSUBSB ] }
@ -594,7 +594,7 @@ M: x86 %saturated-sub-vector-reps
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-vector M: x86 %mul-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ MULPS ] } { float-4-rep [ MULPS ] }
@ -612,7 +612,7 @@ M: x86 %mul-vector-reps
{ sse4.1? { int-4-rep uint-4-rep } } { sse4.1? { int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-high-vector M: x86 %mul-high-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PMULHW ] } { short-8-rep [ PMULHW ] }
@ -624,7 +624,7 @@ M: x86 %mul-high-vector-reps
{ sse2? { short-8-rep ushort-8-rep } } { sse2? { short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-horizontal-add-vector M: x86 %mul-horizontal-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMADDUBSW ] } { char-16-rep [ PMADDUBSW ] }
@ -638,7 +638,7 @@ M: x86 %mul-horizontal-add-vector-reps
{ ssse3? { char-16-rep uchar-16-rep } } { ssse3? { char-16-rep uchar-16-rep } }
} available-reps ; } available-reps ;
M: x86 %div-vector M: x86 %div-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ DIVPS ] } { float-4-rep [ DIVPS ] }
@ -651,7 +651,7 @@ M: x86 %div-vector-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %min-vector M: x86 %min-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMINSB ] } { char-16-rep [ PMINSB ] }
@ -671,7 +671,7 @@ M: x86 %min-vector-reps
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %max-vector M: x86 %max-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMAXSB ] } { char-16-rep [ PMAXSB ] }
@ -691,7 +691,7 @@ M: x86 %max-vector-reps
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %avg-vector M: x86 %avg-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ uchar-16-rep [ PAVGB ] } { uchar-16-rep [ PAVGB ] }
@ -726,7 +726,7 @@ M: x86 %sad-vector-reps
{ sse2? { uchar-16-rep } } { sse2? { uchar-16-rep } }
} available-reps ; } available-reps ;
M: x86 %horizontal-add-vector M: x86 %horizontal-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
signed-rep { signed-rep {
{ float-4-rep [ HADDPS ] } { float-4-rep [ HADDPS ] }
@ -741,7 +741,7 @@ M: x86 %horizontal-add-vector-reps
{ ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } } { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %horizontal-shl-vector-imm M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
two-operand PSLLDQ ; two-operand PSLLDQ ;
M: x86 %horizontal-shl-vector-imm-reps M: x86 %horizontal-shl-vector-imm-reps
@ -749,7 +749,7 @@ M: x86 %horizontal-shl-vector-imm-reps
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %horizontal-shr-vector-imm M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
two-operand PSRLDQ ; two-operand PSRLDQ ;
M: x86 %horizontal-shr-vector-imm-reps M: x86 %horizontal-shr-vector-imm-reps
@ -757,7 +757,7 @@ M: x86 %horizontal-shr-vector-imm-reps
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %abs-vector M: x86 %abs-vector ( dst src rep -- )
{ {
{ char-16-rep [ PABSB ] } { char-16-rep [ PABSB ] }
{ short-8-rep [ PABSW ] } { short-8-rep [ PABSW ] }
@ -769,7 +769,7 @@ M: x86 %abs-vector-reps
{ ssse3? { char-16-rep short-8-rep int-4-rep } } { ssse3? { char-16-rep short-8-rep int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %sqrt-vector M: x86 %sqrt-vector ( dst src rep -- )
{ {
{ float-4-rep [ SQRTPS ] } { float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] } { double-2-rep [ SQRTPD ] }
@ -781,7 +781,7 @@ M: x86 %sqrt-vector-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %and-vector M: x86 %and-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ANDPS ] } { float-4-rep [ ANDPS ] }
@ -795,7 +795,7 @@ M: x86 %and-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %andn-vector M: x86 %andn-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ANDNPS ] } { float-4-rep [ ANDNPS ] }
@ -809,7 +809,7 @@ M: x86 %andn-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %or-vector M: x86 %or-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ORPS ] } { float-4-rep [ ORPS ] }
@ -823,7 +823,7 @@ M: x86 %or-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %xor-vector M: x86 %xor-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ XORPS ] } { float-4-rep [ XORPS ] }
@ -837,7 +837,7 @@ M: x86 %xor-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %shl-vector M: x86 %shl-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PSLLW ] } { short-8-rep [ PSLLW ] }
@ -853,7 +853,7 @@ M: x86 %shl-vector-reps
{ sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %shr-vector M: x86 %shr-vector ( dst src1 src2 rep -- )
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PSRAW ] } { short-8-rep [ PSRAW ] }
@ -911,9 +911,9 @@ M: x86 %integer>scalar drop MOVD ;
] } ] }
} case ; } case ;
M: x86.32 %scalar>integer %scalar>integer-32 ; M: x86.32 %scalar>integer ( dst src rep -- ) %scalar>integer-32 ;
M: x86.64 %scalar>integer M: x86.64 %scalar>integer ( dst src rep -- )
{ {
{ longlong-scalar-rep [ MOVD ] } { longlong-scalar-rep [ MOVD ] }
{ ulonglong-scalar-rep [ MOVD ] } { ulonglong-scalar-rep [ MOVD ] }

View File

@ -46,7 +46,7 @@ HOOK: pic-tail-reg cpu ( -- reg )
: align-stack ( n -- n' ) 16 align ; : align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) (stack-frame-size)
reserved-stack-space + reserved-stack-space +
cell + cell +
@ -60,7 +60,7 @@ M: x86 test-instruction? t ;
M: x86 immediate-store? immediate-comparand? ; M: x86 immediate-store? immediate-comparand? ;
M: x86 %load-immediate M: x86 %load-immediate ( reg val -- )
{ fixnum } declare [ 32-bit-version-of dup XOR ] [ MOV ] if-zero ; { fixnum } declare [ 32-bit-version-of dup XOR ] [ MOV ] if-zero ;
M: x86 %load-reference M: x86 %load-reference
@ -90,13 +90,13 @@ M: x86 %replace-imm
[ [ 0 MOV ] dip rc-absolute rel-literal ] [ [ 0 MOV ] dip rc-absolute rel-literal ]
} cond ; } cond ;
M: x86 %clear M: x86 %clear ( loc -- )
297 swap %replace-imm ; 297 swap %replace-imm ;
M: x86 %inc M: x86 %inc ( loc -- )
[ n>> ] [ ds-loc? ds-reg rs-reg ? ] bi (%inc) ; [ n>> ] [ ds-loc? ds-reg rs-reg ? ] bi (%inc) ;
M: x86 %call 0 CALL rc-relative rel-word-pic ; M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n ) : xt-tail-pic-offset ( -- n )
! See the comment in vm/cpu-x86.hpp ! See the comment in vm/cpu-x86.hpp
@ -104,21 +104,21 @@ M: x86 %call 0 CALL rc-relative rel-word-pic ;
HOOK: %prepare-jump cpu ( -- ) HOOK: %prepare-jump cpu ( -- )
M: x86 %jump M: x86 %jump ( word -- )
%prepare-jump %prepare-jump
0 JMP rc-relative rel-word-pic-tail ; 0 JMP rc-relative rel-word-pic-tail ;
M: x86 %jump-label 0 JMP rc-relative label-fixup ; M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
M: x86 %return 0 RET ; M: x86 %return ( -- ) 0 RET ;
: (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline : (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline : (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
M: x86 %slot (%slot) MOV ; M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ;
M: x86 %slot-imm (%slot-imm) MOV ; M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
M: x86 %set-slot (%slot) swap MOV ; M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm (%slot-imm) swap MOV ; M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
:: two-operand ( dst src1 src2 rep -- dst src ) :: two-operand ( dst src1 src2 rep -- dst src )
dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when
@ -130,13 +130,13 @@ M: x86 %set-slot-imm (%slot-imm) swap MOV ;
dst ; inline dst ; inline
M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %add-imm M: x86 %add-imm ( dst src1 src2 -- )
2over eq? [ 2over eq? [
nip { { 1 [ INC ] } { -1 [ DEC ] } [ ADD ] } case nip { { 1 [ INC ] } { -1 [ DEC ] } [ ADD ] } case
] [ [+] LEA ] if ; ] [ [+] LEA ] if ;
M: x86 %sub int-rep two-operand SUB ; M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm M: x86 %sub-imm ( dst src1 src2 -- )
2over eq? [ 2over eq? [
nip { { 1 [ DEC ] } { -1 [ INC ] } [ SUB ] } case nip { { 1 [ DEC ] } { -1 [ INC ] } [ SUB ] } case
] [ neg [+] LEA ] if ; ] [ neg [+] LEA ] if ;
@ -173,7 +173,7 @@ M: object copy-memory* copy-register* ;
: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ; : ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
M: x86 %copy M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [ 2over eq? [ 3drop ] [
[ [ ?spill-slot ] bi@ ] dip [ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
@ -186,16 +186,16 @@ M: x86 %copy
{ cc/o [ JNO ] } { cc/o [ JNO ] }
} case ; inline } case ; inline
M: x86 %fixnum-add M: x86 %fixnum-add ( label dst src1 src2 cc -- )
[ ADD ] fixnum-overflow ; [ ADD ] fixnum-overflow ;
M: x86 %fixnum-sub M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
[ SUB ] fixnum-overflow ; [ SUB ] fixnum-overflow ;
M: x86 %fixnum-mul M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
[ IMUL2 ] fixnum-overflow ; [ IMUL2 ] fixnum-overflow ;
M: x86 %unbox-alien M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ; alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src -- ) M:: x86 %unbox-any-c-ptr ( dst src -- )
@ -364,7 +364,7 @@ M: x86.64 has-small-reg? 2drop t ;
: %sign-extend ( dst src bits -- ) : %sign-extend ( dst src bits -- )
[ MOVSX ] (%convert-integer) ; inline [ MOVSX ] (%convert-integer) ; inline
M: x86 %convert-integer M: x86 %convert-integer ( dst src c-type -- )
{ {
{ c:char [ 8 %sign-extend ] } { c:char [ 8 %sign-extend ] }
{ c:uchar [ 8 %zero-extend ] } { c:uchar [ 8 %zero-extend ] }
@ -411,10 +411,10 @@ M: x86 %convert-integer
} case } case
] [ nipd %copy ] ?if ; ] [ nipd %copy ] ?if ;
M: x86 %load-memory M: x86 %load-memory ( dst base displacement scale offset rep c-type -- )
(%memory) (%load-memory) ; (%memory) (%load-memory) ;
M: x86 %load-memory-imm M: x86 %load-memory-imm ( dst base offset rep c-type -- )
(%memory-imm) (%load-memory) ; (%memory-imm) (%load-memory) ;
: (%store-memory) ( src exclude address rep c-type -- ) : (%store-memory) ( src exclude address rep c-type -- )
@ -429,10 +429,10 @@ M: x86 %load-memory-imm
} case } case
] [ [ nip swap ] dip %copy ] ?if ; ] [ [ nip swap ] dip %copy ] ?if ;
M: x86 %store-memory M: x86 %store-memory ( src base displacement scale offset rep c-type -- )
(%memory) (%store-memory) ; (%memory) (%store-memory) ;
M: x86 %store-memory-imm M: x86 %store-memory-imm ( src base offset rep c-type -- )
(%memory-imm) (%store-memory) ; (%memory-imm) (%store-memory) ;
: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ; : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
@ -510,16 +510,16 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
M: x86 gc-root-offset M: x86 gc-root-offset
n>> spill-offset special-offset cell + cell /i ; n>> spill-offset special-offset cell + cell /i ;
M: x86 %call-gc M: x86 %call-gc ( gc-map -- )
\ minor-gc %call \ minor-gc %call
gc-map-here ; gc-map-here ;
M: x86 %alien-global M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %prologue cell - decr-stack-reg ; M: x86 %prologue ( n -- ) cell - decr-stack-reg ;
M: x86 %epilogue cell - incr-stack-reg ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: (%boolean) ( dst temp insn -- ) :: (%boolean) ( dst temp insn -- )
dst \ f type-number MOV dst \ f type-number MOV
@ -610,10 +610,10 @@ M:: x86 %dispatch ( src temp -- )
[ (align-code) ] [ (align-code) ]
bi ; bi ;
M: x86 %spill M: x86 %spill ( src rep dst -- )
-rot %copy ; -rot %copy ;
M: x86 %reload M: x86 %reload ( dst rep src -- )
swap %copy ; swap %copy ;
M:: x86 %local-allot ( dst size align offset -- ) M:: x86 %local-allot ( dst size align offset -- )
@ -661,7 +661,10 @@ M:: x86 %alien-assembly ( varargs? reg-inputs stack-inputs
reg-outputs [ first3 %load-reg-param ] each reg-outputs [ first3 %load-reg-param ] each
dead-outputs [ first2 %discard-reg-param ] each ; dead-outputs [ first2 %discard-reg-param ] each ;
M: x86 %alien-invoke M: x86 %alien-invoke ( varargs? reg-inputs stack-inputs
reg-outputs dead-outputs
cleanup stack-size
symbols dll gc-map -- )
'[ _ _ _ %c-invoke ] %alien-assembly ; '[ _ _ _ %c-invoke ] %alien-assembly ;
M:: x86 %alien-indirect ( src M:: x86 %alien-indirect ( src
@ -678,14 +681,14 @@ M:: x86 %alien-indirect ( src
HOOK: %begin-callback cpu ( -- ) HOOK: %begin-callback cpu ( -- )
M: x86 %callback-inputs M: x86 %callback-inputs ( reg-outputs stack-outputs -- )
[ [ first3 %load-reg-param ] each ] [ [ first3 %load-reg-param ] each ]
[ [ first3 %load-stack-param ] each ] bi* [ [ first3 %load-stack-param ] each ] bi*
%begin-callback ; %begin-callback ;
HOOK: %end-callback cpu ( -- ) HOOK: %end-callback cpu ( -- )
M: x86 %callback-outputs M: x86 %callback-outputs ( reg-inputs -- )
%end-callback %end-callback
[ first3 %store-reg-param ] each ; [ first3 %store-reg-param ] each ;
@ -705,10 +708,10 @@ M: x86 long-long-odd-register? f ;
M: x86 float-right-align-on-stack? f ; M: x86 float-right-align-on-stack? f ;
M: x86 immediate-arithmetic? M: x86 immediate-arithmetic? ( n -- ? )
-0x80000000 0x7fffffff between? ; -0x80000000 0x7fffffff between? ;
M: x86 immediate-bitwise? M: x86 immediate-bitwise? ( n -- ? )
-0x80000000 0x7fffffff between? ; -0x80000000 0x7fffffff between? ;
:: %cmov-float= ( dst src -- ) :: %cmov-float= ( dst src -- )
@ -775,7 +778,7 @@ M:: x86 %bit-test ( dst src1 src2 temp -- )
src1 src2 BT src1 src2 BT
dst temp \ CMOVB (%boolean) ; dst temp \ CMOVB (%boolean) ;
M: x86 enable-cpu-features M: x86 enable-cpu-features ( -- )
enable-min/max enable-min/max
enable-log2 enable-log2
enable-bit-test enable-bit-test

View File

@ -86,14 +86,14 @@ M:: x86 %float>integer ( dst src -- )
src2 shuffle-down quot call src2 shuffle-down quot call
ST0 FSTP ; inline ST0 FSTP ; inline
M: x86 %compare-float-ordered M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
[ [ FCOMI ] compare-op ] (%compare-float) ; [ [ FCOMI ] compare-op ] (%compare-float) ;
M: x86 %compare-float-unordered M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
[ [ FUCOMI ] compare-op ] (%compare-float) ; [ [ FUCOMI ] compare-op ] (%compare-float) ;
M: x86 %compare-float-ordered-branch M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
[ [ FCOMI ] compare-op ] (%compare-float-branch) ; [ [ FCOMI ] compare-op ] (%compare-float-branch) ;
M: x86 %compare-float-unordered-branch M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
[ [ FUCOMI ] compare-op ] (%compare-float-branch) ; [ [ FUCOMI ] compare-op ] (%compare-float-branch) ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs classes db.private help.markup help.syntax USING: classes kernel help.markup help.syntax sequences
kernel math quotations sequences strings ; alien assocs strings math quotations db.private ;
IN: db IN: db
HELP: db-connection HELP: db-connection

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs continuations destructors fry kernel USING: arrays assocs classes continuations destructors kernel math
namespaces sequences strings ; namespaces sequences classes.tuple words strings
tools.walker accessors combinators fry db.errors ;
IN: db IN: db
TUPLE: db-connection TUPLE: db-connection
@ -26,7 +27,7 @@ HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ; : dispose-statements ( assoc -- ) values dispose-each ;
M: db-connection dispose M: db-connection dispose ( db-connection -- )
dup db-connection [ dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements [ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements [ dispose-statements H{ } clone ] change-update-statements
@ -76,7 +77,7 @@ GENERIC: bind-tuple ( tuple statement -- )
GENERIC: execute-statement* ( statement type -- ) GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* M: object execute-statement* ( statement type -- )
'[ '[
_ _ drop query-results dispose _ _ drop query-results dispose
] [ ] [
@ -138,9 +139,9 @@ HOOK: begin-transaction db-connection ( -- )
HOOK: commit-transaction db-connection ( -- ) HOOK: commit-transaction db-connection ( -- )
HOOK: rollback-transaction db-connection ( -- ) HOOK: rollback-transaction db-connection ( -- )
M: db-connection begin-transaction "BEGIN" sql-command ; M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
M: db-connection commit-transaction "COMMIT" sql-command ; M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
M: db-connection rollback-transaction "ROLLBACK" sql-command ; M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: in-transaction? ( -- ? ) in-transaction get ; : in-transaction? ( -- ? ) in-transaction get ;

View File

@ -13,7 +13,7 @@ TUPLE: db-pool < pool db ;
: with-db-pool ( db quot -- ) : with-db-pool ( db quot -- )
[ <db-pool> ] dip with-pool ; inline [ <db-pool> ] dip with-pool ; inline
M: db-pool make-connection M: db-pool make-connection ( pool -- conn )
db>> db-open ; db>> db-open ;
: with-pooled-db ( pool quot -- ) : with-pooled-db ( pool quot -- )

View File

@ -31,7 +31,7 @@ IN: db.postgresql.lib
ERROR: postgresql-result-null ; ERROR: postgresql-result-null ;
M: postgresql-result-null summary M: postgresql-result-null summary ( obj -- str )
drop "PQexec returned f." ; drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? ) : postgresql-result-ok? ( res -- ? )
@ -126,7 +126,7 @@ M: postgresql-result-null summary
TUPLE: postgresql-malloc-destructor alien ; TUPLE: postgresql-malloc-destructor alien ;
C: <postgresql-malloc-destructor> postgresql-malloc-destructor C: <postgresql-malloc-destructor> postgresql-malloc-destructor
M: postgresql-malloc-destructor dispose M: postgresql-malloc-destructor dispose ( obj -- )
alien>> PQfreemem ; alien>> PQfreemem ;
: &postgresql-free ( alien -- alien ) : &postgresql-free ( alien -- alien )

View File

@ -25,7 +25,7 @@ TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ; TUPLE: postgresql-result-set < result-set ;
M: postgresql-db db-open M: postgresql-db db-open ( db -- db-connection )
{ {
[ host>> ] [ host>> ]
[ port>> ] [ port>> ]
@ -36,46 +36,46 @@ M: postgresql-db db-open
[ password>> ] [ password>> ]
} cleave connect-postgres <postgresql-db-connection> ; } cleave connect-postgres <postgresql-db-connection> ;
M: postgresql-db-connection db-close PQfinish ; M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
M: postgresql-statement bind-statement* drop ; M: postgresql-statement bind-statement* ( statement -- ) drop ;
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding ) GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
M: sql-spec postgresql-bind-conversion M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
slot-name>> swap get-slot-named <low-level-binding> ; slot-name>> swap get-slot-named <low-level-binding> ;
M: literal-bind postgresql-bind-conversion M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
nip value>> <low-level-binding> ; nip value>> <low-level-binding> ;
M: generator-bind postgresql-bind-conversion M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
dup generator-singleton>> eval-generator dup generator-singleton>> eval-generator
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ; [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple M: postgresql-statement bind-tuple ( tuple statement -- )
[ nip ] [ [ nip ] [
in-params>> in-params>>
[ postgresql-bind-conversion ] with map [ postgresql-bind-conversion ] with map
] 2bi ] 2bi
>>bind-params drop ; >>bind-params drop ;
M: postgresql-result-set #rows M: postgresql-result-set #rows ( result-set -- n )
handle>> PQntuples ; handle>> PQntuples ;
M: postgresql-result-set #columns M: postgresql-result-set #columns ( result-set -- n )
handle>> PQnfields ; handle>> PQnfields ;
: result-handle-n ( result-set -- handle n ) : result-handle-n ( result-set -- handle n )
[ handle>> ] [ n>> ] bi ; [ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column M: postgresql-result-set row-column ( result-set column -- object )
[ result-handle-n ] dip pq-get-string ; [ result-handle-n ] dip pq-get-string ;
M: postgresql-result-set row-column-typed M: postgresql-result-set row-column-typed ( result-set column -- object )
dup pick out-params>> nth type>> dup pick out-params>> nth type>>
[ result-handle-n ] 2dip postgresql-column-typed ; [ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [ dup bind-params>> [
over [ bind-statement ] keep over [ bind-statement ] keep
do-postgresql-bound-statement do-postgresql-bound-statement
@ -85,17 +85,17 @@ M: postgresql-statement query-results
postgresql-result-set new-result-set postgresql-result-set new-result-set
dup init-result-set ; dup init-result-set ;
M: postgresql-result-set advance-row M: postgresql-result-set advance-row ( result-set -- )
[ 1 + ] change-n drop ; [ 1 + ] change-n drop ;
M: postgresql-result-set more-rows? M: postgresql-result-set more-rows? ( result-set -- ? )
[ n>> ] [ max>> ] bi < ; [ n>> ] [ max>> ] bi < ;
M: postgresql-statement dispose M: postgresql-statement dispose ( query -- )
dup handle>> PQclear dup handle>> PQclear
f >>handle drop ; f >>handle drop ;
M: postgresql-result-set dispose M: postgresql-result-set dispose ( result-set -- )
[ handle>> PQclear ] [ handle>> PQclear ]
[ [
0 >>n 0 >>n
@ -103,27 +103,27 @@ M: postgresql-result-set dispose
f >>handle drop f >>handle drop
] bi ; ] bi ;
M: postgresql-statement prepare-statement M: postgresql-statement prepare-statement ( statement -- )
dup dup
[ db-connection get handle>> f ] dip [ db-connection get handle>> f ] dip
[ sql>> ] [ in-params>> ] bi [ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error length f PQprepare postgresql-error
>>handle drop ; >>handle drop ;
M: postgresql-db-connection <simple-statement> M: postgresql-db-connection <simple-statement> ( sql in out -- statement )
postgresql-statement new-statement ; postgresql-statement new-statement ;
M: postgresql-db-connection <prepared-statement> M: postgresql-db-connection <prepared-statement> ( sql in out -- statement )
<simple-statement> dup prepare-statement ; <simple-statement> dup prepare-statement ;
: bind-name% ( -- ) : bind-name% ( -- )
CHAR: $ 0, CHAR: $ 0,
sql-counter [ inc ] [ get 0# ] bi ; sql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db-connection bind% M: postgresql-db-connection bind% ( spec -- )
bind-name% 1, ; bind-name% 1, ;
M: postgresql-db-connection bind# M: postgresql-db-connection bind# ( spec object -- )
[ bind-name% f swap type>> ] dip [ bind-name% f swap type>> ] dip
<literal-bind> 1, ; <literal-bind> 1, ;
@ -169,7 +169,7 @@ M: postgresql-db-connection bind#
"_seq'');' language sql;" 0% "_seq'');' language sql;" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection create-sql-statement M: postgresql-db-connection create-sql-statement ( class -- seq )
[ [
[ create-table-sql , ] keep [ create-table-sql , ] keep
dup db-assigned? [ create-function-sql , ] [ drop ] if dup db-assigned? [ create-function-sql , ] [ drop ] if
@ -189,13 +189,13 @@ M: postgresql-db-connection create-sql-statement
"drop table " 0% 0% drop "drop table " 0% 0% drop
] query-make ; ] query-make ;
M: postgresql-db-connection drop-sql-statement M: postgresql-db-connection drop-sql-statement ( class -- seq )
[ [
[ drop-table-sql , ] keep [ drop-table-sql , ] keep
dup db-assigned? [ drop-function-sql , ] [ drop ] if dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ; ] { } make ;
M: postgresql-db-connection <insert-db-assigned-statement> M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement )
[ [
"select add_" 0% 0% "select add_" 0% 0%
"(" 0% "(" 0%
@ -205,7 +205,7 @@ M: postgresql-db-connection <insert-db-assigned-statement>
");" 0% ");" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection <insert-user-assigned-statement> M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statement )
[ [
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
@ -228,10 +228,10 @@ M: postgresql-db-connection <insert-user-assigned-statement>
");" 0% ");" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection insert-tuple-set-key M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ; query-modify-tuple ;
M: postgresql-db-connection persistent-table M: postgresql-db-connection persistent-table ( -- hashtable )
H{ H{
{ +db-assigned-id+ { "integer" "serial" f } } { +db-assigned-id+ { "integer" "serial" f } }
{ +user-assigned-id+ { f f f } } { +user-assigned-id+ { f f f } }
@ -271,7 +271,7 @@ M: postgresql-db-connection persistent-table
} ; } ;
ERROR: no-compound-found string object ; ERROR: no-compound-found string object ;
M: postgresql-db-connection compound M: postgresql-db-connection compound ( string object -- string' )
over { over {
{ "default" [ first number>string " " glue ] } { "default" [ first number>string " " glue ] }
{ "varchar" [ first number>string "(" ")" surround append ] } { "varchar" [ first number>string "(" ")" surround append ] }

View File

@ -33,7 +33,7 @@ SINGLETON: retryable
] if ] if
] 2map >>bind-params ; ] 2map >>bind-params ;
M: retryable execute-statement* M: retryable execute-statement* ( statement type -- )
drop [ retries>> <iota> ] [ drop [ retries>> <iota> ] [
[ [
nip nip
@ -62,7 +62,7 @@ M: retryable execute-statement*
dup column-name>> 0% " = " 0% bind% dup column-name>> 0% " = " 0% bind%
] interleave ; ] interleave ;
M: db-connection <update-tuple-statement> M: db-connection <update-tuple-statement> ( class -- statement )
[ [
"update " 0% 0% "update " 0% 0%
" set " 0% " set " 0%
@ -71,7 +71,7 @@ M: db-connection <update-tuple-statement>
where-primary-key% where-primary-key%
] query-make ; ] query-make ;
M: random-id-generator eval-generator M: random-id-generator eval-generator ( singleton -- obj )
drop drop
system-random-generator get [ system-random-generator get [
63 [ random-bits ] keep 1 - set-bit 63 [ random-bits ] keep 1 - set-bit
@ -102,32 +102,32 @@ M: random-id-generator eval-generator
: in-parens ( quot -- ) : in-parens ( quot -- )
"(" 0% call ")" 0% ; inline "(" 0% call ")" 0% ; inline
M: interval where M: interval where ( spec obj -- )
[ [
[ from>> "from" where-interval ] [ [ from>> "from" where-interval ] [
nip infinite-interval? [ " and " 0% ] unless nip infinite-interval? [ " and " 0% ] unless
] [ to>> "to" where-interval ] 2tri ] [ to>> "to" where-interval ] 2tri
] in-parens ; ] in-parens ;
M: sequence where M: sequence where ( spec obj -- )
[ [
[ " or " 0% ] [ dupd where ] interleave drop [ " or " 0% ] [ dupd where ] interleave drop
] in-parens ; ] in-parens ;
M: byte-array where M: byte-array where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ; over column-name>> 0% " = " 0% bind# ;
M: NULL where M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ; drop column-name>> 0% " is NULL" 0% ;
: object-where ( spec obj -- ) : object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ; over column-name>> 0% " = " 0% bind# ;
M: object where object-where ; M: object where ( spec obj -- ) object-where ;
M: integer where object-where ; M: integer where ( spec obj -- ) object-where ;
M: string where object-where ; M: string where ( spec obj -- ) object-where ;
: filter-slots ( tuple specs -- specs' ) : filter-slots ( tuple specs -- specs' )
[ [
@ -145,7 +145,7 @@ M: string where object-where ;
: where-clause ( tuple specs -- ) : where-clause ( tuple specs -- )
dupd filter-slots [ drop ] [ many-where ] if-empty ; dupd filter-slots [ drop ] [ many-where ] if-empty ;
M: db-connection <delete-tuples-statement> M: db-connection <delete-tuples-statement> ( tuple table -- sql )
[ [
"delete from " 0% 0% "delete from " 0% 0%
where-clause where-clause
@ -153,7 +153,7 @@ M: db-connection <delete-tuples-statement>
ERROR: all-slots-ignored class ; ERROR: all-slots-ignored class ;
M: db-connection <select-by-slots-statement> M: db-connection <select-by-slots-statement> ( tuple class -- statement )
[ [
"select " 0% "select " 0%
[ dupd filter-ignores ] dip [ dupd filter-ignores ] dip
@ -188,13 +188,13 @@ M: db-connection <select-by-slots-statement>
[ offset>> [ do-offset ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ; } 2cleave ;
M: db-connection query>statement M: db-connection query>statement ( query -- tuple )
[ tuple>> dup class-of ] keep [ tuple>> dup class-of ] keep
[ <select-by-slots-statement> ] dip make-query* ; [ <select-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
M: db-connection <count-statement> M: db-connection <count-statement> ( query -- statement )
[ tuple>> dup class-of ] keep [ tuple>> dup class-of ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ] [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query* ; dip make-query* ;

Some files were not shown because too many files have changed in this diff Show More