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

Merge branch 'master' of git://factorcode.org/git/factor into s3

db4
Daniel Ehrenberg 2010-04-04 19:43:15 -05:00
parent 31f23c8eba c0af678c5b
commit 601b6f8457
266 changed files with 5187 additions and 2650 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
GNUmakefile
View File

@ -52,6 +52,7 @@ ifdef CONFIG
vm/io.o \
vm/jit.o \
vm/math.o \
vm/mvm.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
@ -168,22 +169,16 @@ macosx.app: factor
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor-console: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)

16
Nmakefile
View File

@ -2,11 +2,11 @@
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
LINK_FLAGS = /nologo shell32.lib
LINK_FLAGS = /nologo /safeseh:no shell32.lib
CL_FLAGS = /nologo /O2 /W3
!ENDIF
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \
@ -38,6 +38,8 @@ DLL_OBJS = vm\os-windows-nt.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
vm\mvm.obj \
vm\mvm-windows-nt.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
@ -61,7 +63,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
.rs.res:
rc $<
all: factor.com factor.exe libfactor-ffi-test.dll
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
@ -69,11 +71,11 @@ libfactor-ffi-test.dll: vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.com: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
clean:
del vm\*.obj

5
basis/alarms/alarms-tests.factor
View File

@ -11,7 +11,6 @@ IN: alarms.tests
] unit-test
[ ] [
[
[ resume ] curry instant later drop
] "test" suspend drop
self [ resume ] curry instant later drop
"test" suspend drop
] unit-test

6
basis/alien/data/data-docs.factor
View File

@ -60,6 +60,8 @@ $nl
}
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsections free }
"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
{ $subsections (free) }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsections
&free
@ -148,9 +150,9 @@ $nl
}
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"The C type " { $link char } { $snippet "*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsections alien>string }
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call one of the above words before passing the pointer to " { $link free } "." ;
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;

4
basis/bit-sets/bit-sets-docs.factor
View File

@ -3,9 +3,9 @@ IN: bit-sets
ARTICLE: "bit-sets" "Bit sets"
"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
"Bit sets are of the class"
"Bit sets form a class:"
{ $subsection bit-set }
"They can be instantiated with the word"
"Constructing new bit sets:"
{ $subsection <bit-set> } ;
ABOUT: "bit-sets"

7
basis/bootstrap/compiler/compiler.factor
View File

@ -20,11 +20,8 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
"alien.debugger" require
] when
"prettyprint" "alien.prettyprint" require-when
"debugger" "alien.debugger" require-when
"cpu." cpu name>> append require

2
basis/bootstrap/handbook/handbook.factor
View File

@ -1,4 +1,4 @@
USING: vocabs.loader vocabs kernel ;
IN: bootstrap.handbook
"bootstrap.help" vocab [ "help.handbook" require ] when
"bootstrap.help" "help.handbook" require-when

13
basis/bootstrap/image/image.factor
View File

@ -15,10 +15,11 @@ generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
[ dup "winnt" = "winnt" "unix" ? ] dip
{
{ "ppc" [ "-ppc" append ] }
{ "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
[ nip ]
{ "ppc" [ drop "-ppc" append ] }
{ "x86.32" [ nip "-x86.32" append ] }
{ "x86.64" [ nip "-x86.64" append ] }
} case ;
: my-arch ( -- arch )
@ -32,7 +33,7 @@ IN: bootstrap.image
: images ( -- seq )
{
"x86.32"
"winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
@ -129,8 +130,8 @@ SYMBOL: jit-literals
: jit-vm ( offset rc -- )
[ jit-parameter ] dip rt-vm jit-rel ;
: jit-dlsym ( name library rc -- )
rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
: jit-dlsym ( name rc -- )
rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len

6
basis/bootstrap/threads/threads.factor
View File

@ -1,11 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel io.thread threads
USING: vocabs.loader kernel io.thread threads
compiler.utilities namespaces ;
IN: bootstrap.threads
"debugger" vocab [
"debugger.threads" require
] when
"debugger" "debugger.threads" require-when
[ yield ] yield-hook set-global

4
basis/bootstrap/ui/tools/tools.factor
View File

@ -4,9 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
"ui.backend.cocoa" vocab [
"ui.backend.cocoa.tools" require
] when
"ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
"ui.tools.walker" require
] when

12
basis/boxes/boxes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
IN: boxes
@ -11,16 +11,18 @@ ERROR: box-full box ;
: >box ( value box -- )
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
[ box-full ] [ t >>occupied (>>value) ] if ; inline
ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value )
dup occupied>>
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
check-box [ f ] change-value f >>occupied drop ; inline
: ?box ( box -- value/f ? )
dup occupied>> [ box> t ] [ drop f f ] if ;
dup occupied>> [ box> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline

12
basis/calendar/calendar-docs.factor
View File

@ -76,27 +76,27 @@ HELP: day-abbreviation3
} related-words
HELP: average-month
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number

10
basis/calendar/calendar-tests.factor
View File

@ -176,3 +176,13 @@ IN: calendar.tests
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
[ t ] [
2009 1 29 <date> 1 months time+
2009 3 1 <date> =
] unit-test
[ t ] [
2008 1 29 <date> 1 months time+
2008 2 29 <date> =
] unit-test

14
basis/calendar/calendar.factor
View File

@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
: days-per-year ( -- ratio ) 3652425/10000 ; inline
: hours-per-year ( -- ratio ) 876582/100 ; inline
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
CONSTANT: average-month 30+5/12
CONSTANT: months-per-year 12
CONSTANT: days-per-year 3652425/10000
CONSTANT: hours-per-year 876582/100
CONSTANT: minutes-per-year 5259492/10
CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
@ -200,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp )
[ 3 >>month 1 >>day ] when ;
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
[ + ] curry change-year adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;

6
basis/channels/channels.factor
View File

@ -17,7 +17,7 @@ GENERIC: from ( channel -- value )
<PRIVATE
: wait ( channel -- )
[ senders>> push ] curry
[ self ] dip senders>> push
"channel send" suspend drop ;
: (to) ( value receivers -- )
@ -36,7 +36,7 @@ M: channel to ( value channel -- )
[ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
[
[ self ] dip
notify senders>>
[ (from) ] unless-empty
] curry "channel receive" suspend ;
"channel receive" suspend ;

2
basis/classes/struct/struct.factor
View File

@ -404,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT:
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
"prettyprint" "classes.struct.prettyprint" require-when

3
basis/cocoa/messages/messages.factor
View File

@ -5,8 +5,7 @@ classes.struct continuations combinators compiler compiler.alien
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
libc.private lexer init core-foundation fry generalizations
specialized-arrays ;
lexer init core-foundation fry generalizations specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages

4
basis/command-line/command-line-docs.factor
View File

@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"

6
basis/compiler/alien/alien.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
alien.c-types cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
: large-struct? ( type -- ? )
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ void* prefix ] when ;
: alien-return ( params -- ctype )
: alien-return ( params -- type )
return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )

8
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field-ptr insn-slot# field-name>> ;
M: ##vm-field insn-slot# offset>> ;
M: ##set-vm-field insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
M: ##vm-field insn-object drop \ ##vm-field ;
M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
0 ac-counter set
next-ac heap-ac set
\ ##vm-field-ptr set-new-ac
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ;

12
basis/compiler/cfg/instructions/instructions.factor
View File

@ -660,9 +660,13 @@ INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
INSN: ##vm-field-ptr
INSN: ##vm-field
def: dst/int-rep
literal: field-name ;
literal: offset ;
INSN: ##set-vm-field
use: src/int-rep
literal: offset ;
! FFI
INSN: ##alien-invoke
@ -831,8 +835,8 @@ UNION: ##allocation
##box-displaced-alien ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -30,7 +30,9 @@ IN: compiler.cfg.intrinsics
{
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:context-object [ emit-context-object ] }
{ kernel.private:special-object [ emit-special-object ] }
{ kernel.private:set-special-object [ emit-set-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }

31
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -1,19 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces layouts sequences kernel math accessors
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.builder.blocks
compiler.cfg.utilities ;
FROM: vm => context-field-offset vm-field-offset ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: special-object-offset ( n -- offset )
cells "special-objects" vm-field-offset + ;
: emit-special-object ( node -- )
"special-objects" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;
dup node-input-infos first literal>> [
ds-drop
special-object-offset ^^vm-field
ds-push
] [ emit-primitive ] ?if ;
: emit-set-special-object ( node -- )
dup node-input-infos second literal>> [
ds-drop
[ ds-pop ] dip special-object-offset ##set-vm-field
] [ emit-primitive ] ?if ;
: context-object-offset ( n -- n )
cells "context-objects" context-field-offset + ;
: emit-context-object ( node -- )
dup node-input-infos first literal>> [
"ctx" vm-field-offset ^^vm-field
ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- )
ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm

8
basis/compiler/codegen/codegen.factor
View File

@ -210,7 +210,8 @@ CODEGEN: ##compare-imm %compare-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
@ -458,7 +459,7 @@ M: ##alien-indirect generate-insn
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
%nest-stacks
%begin-callback
box-parameters
] with-param-regs ;
@ -482,5 +483,4 @@ M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
[ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;

7
basis/compiler/constants/constants.factor
View File

@ -28,10 +28,16 @@ CONSTANT: deck-bits 18
: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
: vm-spare-context-offset ( -- n ) 1 bootstrap-cells ; inline
: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
: context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline
: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline
: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline
: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline
: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
@ -59,6 +65,7 @@ CONSTANT: rt-megamorphic-cache-hits 8
CONSTANT: rt-vm 9
CONSTANT: rt-cards-offset 10
CONSTANT: rt-decks-offset 11
CONSTANT: rt-exception-handler 12
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

28
basis/compiler/tests/alien.factor
View File

@ -4,7 +4,7 @@ compiler continuations effects io io.backend io.pathnames
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
system threads tools.test words alien.complex ;
system threads tools.test words alien.complex concurrency.promises ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
@ -432,14 +432,17 @@ STRUCT: double-rect
void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
: double-rect-test ( arg callback -- arg' )
[ f f ] 2dip
void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
[
1.0 2.0 3.0 4.0 <double-rect>
double-rect-callback double-rect-test
>double-rect<
] unit-test
STRUCT: test_struct_14
{ x1 double }
@ -579,6 +582,21 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
] unless
! Test interaction between threads and callbacks
: thread-callback-1 ( -- callback )
int { } "cdecl" [ yield 100 ] alien-callback ;
: thread-callback-2 ( -- callback )
int { } "cdecl" [ yield 200 ] alien-callback ;
: thread-callback-invoker ( callback -- n )
int { } "cdecl" alien-indirect ;
<promise> "p" set
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
[ 100 ] [ "p" get ?promise ] unit-test
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -467,6 +467,12 @@ TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
unit-test
TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
[ V{ f } ]
[ [ don't-fold-boa-test-tuple boa ] final-literals ]
unit-test
TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [

17
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -34,17 +34,18 @@ IN: compiler.tree.propagation.slots
[ read-only>> [ value-info ] [ drop f ] if ] 2map
f prefix ;
: (propagate-tuple-constructor) ( values class -- info )
[ read-only-slots ] keep
over rest-slice [ dup [ literal?>> ] when ] all? [
[ rest-slice ] dip fold-<tuple-boa>
] [
<tuple-info>
] if ;
: fold-<tuple-boa>? ( values class -- ? )
[ rest-slice [ dup [ literal?>> ] when ] all? ]
[ identity-tuple class<= not ]
bi* and ;
: (propagate-<tuple-boa>) ( values class -- info )
[ read-only-slots ] keep 2dup fold-<tuple-boa>?
[ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
: propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last
value-info literal>> first (propagate-tuple-constructor) 1array ;
value-info literal>> first (propagate-<tuple-boa>) 1array ;
: read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip

15
basis/concurrency/conditions/conditions.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques threads kernel arrays sequences alarms fry ;
IN: concurrency.conditions
: notify-1 ( deque -- )
dup deque-empty? [ drop ] [ pop-back resume-now ] if ;
dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
: notify-all ( deque -- )
[ resume-now ] slurp-deque ;
[ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
@ -22,10 +22,13 @@ IN: concurrency.conditions
ERROR: wait-timeout ;
: queue ( queue -- )
[ self ] dip push-front ; inline
: wait ( queue timeout status -- )
over [
[ queue-timeout [ drop ] ] dip suspend
[ queue-timeout ] dip suspend
[ wait-timeout ] [ cancel-alarm ] if
] [
[ drop '[ _ push-front ] ] dip suspend drop
] if ;
[ drop queue ] dip suspend drop
] if ; inline

2
basis/concurrency/distributed/distributed.factor
View File

@ -20,7 +20,7 @@ PRIVATE>
registered-remote-threads delete-at ;
: get-remote-thread ( name -- thread )
dup registered-remote-threads at [ ] [ thread ] ?if ;
dup registered-remote-threads at [ ] [ threads at ] ?if ;
SYMBOL: local-node

5
basis/concurrency/exchangers/exchangers.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes accessors fry ;
IN: concurrency.exchangers
@ -17,5 +17,6 @@ TUPLE: exchanger thread object ;
[ thread>> box> resume-with ] dip
] [
[ object>> >box ] keep
'[ _ thread>> >box ] "exchange" suspend
[ self ] dip thread>> >box
"exchange" suspend
] if ;

21
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads
locals fry ;
IN: concurrency.mailboxes
TUPLE: mailbox threads data ;
TUPLE: mailbox { threads dlist } { data dlist } ;
: <mailbox> ( -- mailbox )
mailbox new
<dlist> >>threads
<dlist> >>data ;
<dlist> >>data ; inline
: mailbox-empty? ( mailbox -- bool )
data>> deque-empty? ;
data>> deque-empty? ; inline
: mailbox-put ( obj mailbox -- )
GENERIC: mailbox-put ( obj mailbox -- )
M: mailbox mailbox-put
[ data>> push-front ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
[ threads>> ] dip "mailbox" wait ; inline
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
@ -34,16 +36,17 @@ TUPLE: mailbox threads data ;
2dup wait-for-mailbox block-if-empty
] [
drop
] if ;
] if ; inline recursive
: mailbox-peek ( mailbox -- obj )
data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty data>> pop-back ;
GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
f mailbox-get-timeout ; inline
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty

20
basis/concurrency/messaging/messaging.factor
View File

@ -1,20 +1,22 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs accessors summary fry ;
USING: kernel kernel.private threads concurrency.mailboxes
continuations namespaces assocs accessors summary fry ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
: mailbox-of ( thread -- mailbox )
dup mailbox>> [ ] [
<mailbox> [ >>mailbox drop ] keep
] ?if ;
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
dup mailbox>>
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- )
check-registered mailbox-of mailbox-put ;
mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ;
: my-mailbox ( -- mailbox ) self mailbox-of ; inline
: receive ( -- message )
my-mailbox mailbox-get ?linked ;

5
basis/core-foundation/file-descriptors/file-descriptors.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
USING: alien.c-types alien.syntax kernel math.bitwise core-foundation
literals ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
@ -25,7 +26,7 @@ FUNCTION: void CFFileDescriptorEnableCallBacks (
) ;
: enable-all-callbacks ( fd -- )
{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
CFFileDescriptorEnableCallBacks ;
: <CFFileDescriptor> ( fd callback -- handle )

22
basis/core-graphics/core-graphics.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities
opengl.gl ;
opengl.gl literals ;
IN: core-graphics
! CGImageAlphaInfo
@ -16,15 +16,15 @@ kCGImageAlphaFirst
kCGImageAlphaNoneSkipLast
kCGImageAlphaNoneSkipFirst ;
: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
CONSTANT: kCGBitmapFloatComponents 256
: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
CONSTANT: kCGBitmapByteOrderMask HEX: 7000
CONSTANT: kCGBitmapByteOrderDefault 0
CONSTANT: kCGBitmapByteOrder16Little 4096
CONSTANT: kCGBitmapByteOrder32Little 8192
CONSTANT: kCGBitmapByteOrder16Big 12288
CONSTANT: kCGBitmapByteOrder32Big 16384
: kCGBitmapByteOrder16Host ( -- n )
little-endian?
@ -121,8 +121,8 @@ FUNCTION: uint GetCurrentButtonState ( ) ;
<PRIVATE
: bitmap-flags ( -- flags )
{ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
: bitmap-flags ( -- n )
kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;

14
basis/cpu/architecture/architecture.factor
View File

@ -447,8 +447,10 @@ HOOK: %set-alien-double cpu ( ptr offset value -- )
HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst fieldname -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %vm-field cpu ( dst offset -- )
HOOK: %set-vm-field cpu ( src offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
@ -582,13 +584,13 @@ HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
HOOK: %begin-callback cpu ( -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
HOOK: %end-callback cpu ( -- )
HOOK: %nest-stacks cpu ( -- )
HOOK: %unnest-stacks cpu ( -- )
HOOK: %end-callback-value cpu ( c-type -- )
HOOK: callback-return-rewind cpu ( params -- n )

189
basis/cpu/ppc/bootstrap.factor
View File

@ -3,7 +3,8 @@
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.units compiler.constants math
math.private math.ranges layouts words vocabs slots.private
locals locals.backend generic.single.private fry sequences ;
locals locals.backend generic.single.private fry sequences
threads.private ;
FROM: cpu.ppc.assembler => B ;
IN: bootstrap.ppc
@ -14,6 +15,22 @@ CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
CONSTANT: vm-reg 15
CONSTANT: ctx-reg 16
CONSTANT: nv-reg 17
: jit-call ( string -- )
0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL ;
: jit-call-quot ( -- )
4 3 quot-entry-point-offset LWZ
4 MTLR
BLRL ;
: jit-jump-quot ( -- )
4 3 quot-entry-point-offset LWZ
4 MTCTR
BCTR ;
: factor-area-size ( -- n ) 16 ;
@ -52,29 +69,71 @@ CONSTANT: ctx-reg 16
saved-int-regs-size +
saved-fp-regs-size +
saved-vec-regs-size +
4 +
16 align ;
: old-context-save-offset ( -- n )
432 save-at ;
[
! Save old stack pointer
11 1 MR
! Create stack frame
0 MFLR
1 1 callback-frame-size neg STWU
1 1 callback-frame-size SUBI
0 1 callback-frame-size lr-save + STW
! Save all non-volatile registers
nv-int-regs [ 4 * save-int ] each-index
nv-fp-regs [ 8 * 80 + save-fp ] each-index
nv-vec-regs [ 16 * 224 + save-vec ] each-index
! Stick old stack pointer in a non-volatile register so that
! callbacks can access their arguments
nv-reg 11 MR
! Load VM into vm-reg
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
! Save old context
2 vm-reg vm-context-offset LWZ
2 1 old-context-save-offset STW
! Switch over to the spare context
2 vm-reg vm-spare-context-offset LWZ
2 vm-reg vm-context-offset STW
! Save C callstack pointer
1 2 context-callstack-save-offset STW
! Load Factor callstack pointer
1 2 context-callstack-bottom-offset LWZ
! Call into Factor code
0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel
2 MTLR
BLRL
! Load VM again, pointlessly
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
! Load C callstack pointer
2 vm-reg vm-context-offset LWZ
1 2 context-callstack-save-offset LWZ
! Load old context
2 1 old-context-save-offset LWZ
2 vm-reg vm-context-offset STW
! Restore non-volatile registers
nv-vec-regs [ 16 * 224 + restore-vec ] each-index
nv-fp-regs [ 8 * 80 + restore-fp ] each-index
nv-int-regs [ 4 * restore-int ] each-index
! Tear down stack frame and return
0 1 callback-frame-size lr-save + LWZ
1 1 0 LWZ
1 1 callback-frame-size ADDI
0 MTLR
BLR
] callback-stub jit-define
@ -92,7 +151,6 @@ CONSTANT: ctx-reg 16
rs-reg ctx-reg context-retainstack-offset STW ;
: jit-restore-context ( -- )
jit-load-context
ds-reg ctx-reg context-datastack-offset LWZ
rs-reg ctx-reg context-retainstack-offset LWZ ;
@ -267,9 +325,8 @@ CONSTANT: ctx-reg 16
jit-save-context
3 6 MR
4 vm-reg MR
0 5 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym
5 MTLR
BLRL
"inline_cache_miss" jit-call
jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
@ -321,10 +378,9 @@ CONSTANT: ctx-reg 16
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
5 3 quot-entry-point-offset LWZ
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive
[ jit-call-quot ]
[ jit-jump-quot ] \ (call) define-combinator-primitive
[
3 ds-reg 0 LWZ
@ -343,14 +399,22 @@ CONSTANT: ctx-reg 16
! Special primitives
[
nv-reg 3 MR
3 vm-reg MR
"begin_callback" jit-call
jit-load-context
jit-restore-context
! Save ctx->callstack_bottom
1 ctx-reg context-callstack-bottom-offset STW
! Call quotation
5 3 quot-entry-point-offset LWZ
5 MTLR
BLRL
3 nv-reg MR
jit-call-quot
jit-save-context
3 vm-reg MR
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
@ -362,6 +426,7 @@ CONSTANT: ctx-reg 16
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
! Load ds and rs registers
jit-load-context
jit-restore-context
! We have changed the stack; load return address again
@ -369,9 +434,7 @@ CONSTANT: ctx-reg 16
0 MTLR
! Call quotation
4 3 quot-entry-point-offset LWZ
4 MTCTR
BCTR
jit-call-quot
] \ unwind-native-frames define-sub-primitive
[
@ -392,9 +455,7 @@ CONSTANT: ctx-reg 16
1 3 MR
! Call memcpy; arguments are now in the correct registers
1 1 -64 STWU
0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
"factor_memcpy" jit-call
1 1 0 LWZ
! Return with new callstack
0 1 lr-save LWZ
@ -405,13 +466,10 @@ CONSTANT: ctx-reg 16
[
jit-save-context
4 vm-reg MR
0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
5 3 quot-entry-point-offset LWZ
"lazy_jit_compile" jit-call
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ]
[ jit-call-quot ]
[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Objects
@ -665,9 +723,7 @@ CONSTANT: ctx-reg 16
[ BNO ]
[
5 vm-reg MR
0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym
6 MTLR
BLRL
func jit-call
]
jit-conditional* ;
@ -689,11 +745,78 @@ CONSTANT: ctx-reg 16
[
4 4 tag-bits get SRAWI
5 vm-reg MR
0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym
6 MTLR
BLRL
"overflow_fixnum_multiply" jit-call
]
jit-conditional*
] \ fixnum* define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-save-context
! Make the new context the current one
ctx-reg swap MR
ctx-reg vm-reg vm-context-offset STW
! Load new stack pointer
1 ctx-reg context-callstack-top-offset LWZ
! Load new ds, rs registers
jit-restore-context ;
: jit-pop-context-and-param ( -- )
3 ds-reg 0 LWZ
3 3 alien-offset LWZ
4 ds-reg -4 LWZ
ds-reg ds-reg 8 SUBI ;
: jit-push-param ( -- )
ds-reg ds-reg 4 ADDI
4 ds-reg 0 STW ;
: jit-set-context ( -- )
jit-pop-context-and-param
3 jit-switch-context
jit-push-param ;
[ jit-set-context ] \ (set-context) define-sub-primitive
: jit-pop-quot-and-param ( -- )
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
ds-reg ds-reg 8 SUBI ;
: jit-start-context ( -- )
! Create the new context in return-reg
3 vm-reg MR
"new_context" jit-call
6 3 MR
jit-pop-quot-and-param
6 jit-switch-context
jit-push-param
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-context
3 vm-reg MR
4 ctx-reg MR
"delete_context" jit-call ;
[
jit-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
[
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit

66
basis/cpu/ppc/ppc.factor
View File

@ -58,11 +58,9 @@ CONSTANT: vm-reg 15
: %load-vm-addr ( reg -- ) vm-reg MR ;
M: ppc %vm-field ( dst field -- )
[ vm-reg ] dip vm-field-offset LWZ ;
M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
M: ppc %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset ADDI ;
M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
GENERIC: loc-reg ( loc -- reg )
@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ;
M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
"nursery" %vm-field-ptr ;
vm-reg "nursery" vm-field-offset ADDI ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
} case ;
: next-param@ ( n -- reg x )
2 1 stack-frame get total-size>> LWZ
[ 2 ] dip param@ ;
[ 17 ] dip param@ ;
: store-to-frame ( src n rep -- )
{
@ -604,14 +601,14 @@ M: ppc %push-stack ( -- )
int-regs return-reg ds-reg 0 STW ;
M: ppc %push-context-stack ( -- )
11 "ctx" %vm-field
11 %context
12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- )
11 "ctx" %vm-field
11 %context
12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
@ -677,14 +674,12 @@ M: ppc %box-large-struct ( n c-type -- )
"from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field
temp2 1 stack-frame get total-size>> ADDI
temp2 temp1 "callstack-bottom" context-field-offset STW
temp1 %context
ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field
temp1 %context
1 temp1 "callstack-top" context-field-offset STW
ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ;
@ -692,14 +687,6 @@ M:: ppc %save-context ( temp1 temp2 -- )
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 4 %restore-context
3 swap %load-reference
4 3 quot-entry-point-offset LWZ
4 MTLR
BLRL
3 4 %save-context ;
M: ppc %prepare-alien-indirect ( -- )
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
@ -710,18 +697,6 @@ M: ppc %prepare-alien-indirect ( -- )
M: ppc %alien-indirect ( -- )
16 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
3 %load-vm-addr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Restore top of data stack
3 1 0 local@ LWZ
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
@ -757,13 +732,30 @@ M: ppc %box-small-struct ( c-type -- )
4 3 4 LWZ
3 3 0 LWZ ;
M: ppc %nest-stacks ( -- )
M: ppc %begin-callback ( -- )
3 %load-vm-addr
"nest_stacks" f %alien-invoke ;
"begin_callback" f %alien-invoke ;
M: ppc %unnest-stacks ( -- )
M: ppc %alien-callback ( quot -- )
3 4 %restore-context
3 swap %load-reference
4 3 quot-entry-point-offset LWZ
4 MTLR
BLRL
3 4 %save-context ;
M: ppc %end-callback ( -- )
3 %load-vm-addr
"unnest_stacks" f %alien-invoke ;
"end_callback" f %alien-invoke ;
M: ppc %end-callback-value ( ctype -- )
! Save top of data stack
16 ds-reg 0 LWZ
%end-callback
! Restore top of data stack
3 16 MR
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {

32
basis/cpu/x86/32/32.factor
View File

@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field ( dst field -- )
[ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
[ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %set-vm-field ( dst field -- )
[ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
[ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- )
EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- )
temp-reg "ctx" %vm-field
temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -228,14 +231,6 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
0 stack@ EAX MOV
"to_value_struct" f %alien-invoke ;
M: x86.32 %nest-stacks ( -- )
0 save-vm-ptr
"nest_stacks" f %alien-invoke ;
M: x86.32 %unnest-stacks ( -- )
0 save-vm-ptr
"unnest_stacks" f %alien-invoke ;
M: x86.32 %prepare-alien-indirect ( -- )
EAX ds-reg [] MOV
ds-reg 4 SUB
@ -247,18 +242,25 @@ M: x86.32 %prepare-alien-indirect ( -- )
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
ESP 4 [+] 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
EAX EDX %restore-context
EAX swap %load-reference
EAX quot-entry-point-offset [+] CALL
EAX EDX %save-context ;
M: x86.32 %callback-value ( ctype -- )
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f %alien-invoke ;
M: x86.32 %end-callback-value ( ctype -- )
%pop-context-stack
4 stack@ EAX MOV
0 save-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
%end-callback
! Place former top of data stack back in EAX
EAX 4 stack@ MOV
! Unbox EAX

165
basis/cpu/x86/32/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler cpu.x86.assembler.operands layouts
vocabs parser compiler.constants sequences math math.private
generic.single.private ;
generic.single.private threads.private ;
IN: bootstrap.x86
4 \ cell set
@ -16,17 +16,20 @@ IN: bootstrap.x86
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
: temp3 ( -- reg ) EBX ;
: safe-reg ( -- reg ) EAX ;
: stack-reg ( -- reg ) ESP ;
: frame-reg ( -- reg ) EBP ;
: vm-reg ( -- reg ) ECX ;
: ctx-reg ( -- reg ) EBP ;
: nv-regs ( -- seq ) { ESI EDI EBX } ;
: nv-reg ( -- reg ) EBX ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
: jit-call ( name -- )
0 CALL rc-relative jit-dlsym ;
[
! save stack frame size
stack-frame-size PUSH
@ -49,7 +52,8 @@ IN: bootstrap.x86
ctx-reg vm-reg vm-context-offset [+] MOV ;
: jit-save-context ( -- )
EDX RSP -4 [+] LEA
jit-load-context
EDX ESP -4 [+] LEA
ctx-reg context-callstack-top-offset [+] EDX MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
@ -59,40 +63,59 @@ IN: bootstrap.x86
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
jit-load-vm
jit-load-context
jit-save-context
! call the primitive
ESP [] vm-reg MOV
0 CALL rc-relative rt-dlsym jit-rel
! restore ds, rs registers
jit-restore-context
] jit-primitive jit-define
: jit-jump-quot ( -- )
EAX quot-entry-point-offset [+] JMP ;
: jit-call-quot ( -- )
EAX quot-entry-point-offset [+] CALL ;
[
! Load quotation
jit-load-vm
ESP [] vm-reg MOV
EAX EBP 8 [+] MOV
! save ctx->callstack_bottom, load ds, rs registers
ESP 4 [+] EAX MOV
"begin_callback" jit-call
jit-load-vm
jit-load-context
jit-restore-context
EDX stack-reg stack-frame-size 4 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] EDX MOV
! call the quotation
EAX quot-entry-point-offset [+] CALL
! save ds, rs registers
jit-call-quot
jit-load-vm
jit-save-context
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
EAX ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
[ EAX quot-entry-point-offset [+] CALL ]
[ EAX quot-entry-point-offset [+] JMP ]
[ jit-call-quot ]
[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
! Load ds and rs registers
jit-load-vm
jit-load-context
jit-restore-context
! Windows-specific setup
ctx-reg jit-update-seh
! Clear x87 stack, but preserve rounding mode and exception flags
ESP 2 SUB
ESP [] FNSTCW
@ -107,13 +130,7 @@ IN: bootstrap.x86
! Unwind stack frames
ESP EDX MOV
! Load ds and rs registers
jit-load-vm
jit-load-context
jit-restore-context
! Call quotation
EAX quot-entry-point-offset [+] JMP
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
@ -137,7 +154,7 @@ IN: bootstrap.x86
EDX PUSH
EBP PUSH
EAX PUSH
0 CALL "factor_memcpy" f rc-relative jit-dlsym
"factor_memcpy" jit-call
ESP 12 ADD
! Return with new callstack
0 RET
@ -145,7 +162,6 @@ IN: bootstrap.x86
[
jit-load-vm
jit-load-context
jit-save-context
! Store arguments
@ -153,10 +169,10 @@ IN: bootstrap.x86
ESP 4 [+] vm-reg MOV
! Call VM
0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
"lazy_jit_compile" jit-call
]
[ EAX quot-entry-point-offset [+] CALL ]
[ EAX quot-entry-point-offset [+] JMP ]
[ jit-call-quot ]
[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
@ -167,11 +183,10 @@ IN: bootstrap.x86
! frame, and the stack. The frame setup takes this into account.
: jit-inline-cache-miss ( -- )
jit-load-vm
jit-load-context
jit-save-context
ESP 4 [+] vm-reg MOV
ESP [] EBX MOV
0 CALL "inline_cache_miss" f rc-relative jit-dlsym
"inline_cache_miss" jit-call
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
@ -188,7 +203,6 @@ IN: bootstrap.x86
: jit-overflow ( insn func -- )
ds-reg 4 SUB
jit-load-vm
jit-load-context
jit-save-context
EAX ds-reg [] MOV
EDX ds-reg 4 [+] MOV
@ -200,7 +214,7 @@ IN: bootstrap.x86
ESP [] EAX MOV
ESP 4 [+] EDX MOV
ESP 8 [+] vm-reg MOV
[ 0 CALL ] dip f rc-relative jit-dlsym
jit-call
]
jit-conditional ;
@ -211,7 +225,6 @@ IN: bootstrap.x86
[
ds-reg 4 SUB
jit-load-vm
jit-load-context
jit-save-context
EBX ds-reg [] MOV
EAX EBX MOV
@ -225,10 +238,98 @@ IN: bootstrap.x86
ESP [] EBX MOV
ESP 4 [+] EBP MOV
ESP 8 [+] vm-reg MOV
0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
"overflow_fixnum_multiply" jit-call
]
jit-conditional
] \ fixnum* define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-load-vm
jit-save-context
! Make the new context the current one
ctx-reg swap MOV
vm-reg vm-context-offset [+] ctx-reg MOV
! Load new stack pointer
ESP ctx-reg context-callstack-top-offset [+] MOV
! Windows-specific setup
ctx-reg jit-update-tib
! Load new ds, rs registers
jit-restore-context ;
: jit-set-context ( -- )
! Load context and parameter from datastack
EAX ds-reg [] MOV
EAX EAX alien-offset [+] MOV
EBX ds-reg -4 [+] MOV
ds-reg 8 SUB
! Make the new context active
EAX jit-switch-context
! Windows-specific setup
ctx-reg jit-update-seh
! Twiddle stack for return
ESP 4 ADD
! Store parameter to datastack
ds-reg 4 ADD
ds-reg [] EBX MOV ;
[ jit-set-context ] \ (set-context) define-sub-primitive
: jit-start-context ( -- )
! Create the new context in return-reg
jit-load-vm
ESP [] vm-reg MOV
"new_context" jit-call
! Save pointer to quotation and parameter
EBX ds-reg MOV
ds-reg 8 SUB
! Make the new context active
EAX jit-switch-context
! Push parameter
EAX EBX -4 [+] MOV
ds-reg 4 ADD
ds-reg [] EAX MOV
! Windows-specific setup
jit-install-seh
! Push a fake return address
0 PUSH
! Jump to initial quotation
EAX EBX [] MOV
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-vm
jit-load-context
ESP [] vm-reg MOV
ESP 4 [+] ctx-reg MOV
"delete_context" jit-call ;
[
jit-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
[
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call

14
basis/cpu/x86/32/unix/bootstrap.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
layouts parser sequences ;
IN: bootstrap.x86
: jit-save-tib ( -- ) ;
: jit-restore-tib ( -- ) ;
: jit-update-tib ( ctx-reg -- ) drop ;
: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
: jit-update-seh ( ctx-reg -- ) drop ;
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
call

54
basis/cpu/x86/32/winnt/bootstrap.factor Normal file
View File

@ -0,0 +1,54 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private compiler.constants
cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
locals parser sequences ;
IN: bootstrap.x86
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
: jit-save-tib ( -- )
tib-exception-list-offset [] FS PUSH
tib-stack-base-offset [] FS PUSH
tib-stack-limit-offset [] FS PUSH ;
: jit-restore-tib ( -- )
tib-stack-limit-offset [] FS POP
tib-stack-base-offset [] FS POP
tib-exception-list-offset [] FS POP ;
:: jit-update-tib ( ctx-reg -- )
! There's a redundant load here because we're not allowed
! to clobber ctx-reg. Clobbers EAX.
! Save callstack base in TIB
EAX ctx-reg context-callstack-seg-offset [+] MOV
EAX EAX segment-end-offset [+] MOV
tib-stack-base-offset [] EAX FS MOV
! Save callstack limit in TIB
EAX ctx-reg context-callstack-seg-offset [+] MOV
EAX EAX segment-start-offset [+] MOV
tib-stack-limit-offset [] EAX FS MOV ;
: jit-install-seh ( -- )
! Create a new exception record and store it in the TIB.
! Align stack
ESP 3 bootstrap-cells ADD
! Exception handler address filled in by callback.cpp
0 PUSH rc-absolute-cell rt-exception-handler jit-rel
! No next handler
0 PUSH
! This is the new exception handler
tib-exception-list-offset [] ESP FS MOV ;
:: jit-update-seh ( ctx-reg -- )
! Load exception record structure that jit-install-seh
! created from the bottom of the callstack. Clobbers EAX.
EAX ctx-reg context-callstack-bottom-offset [+] MOV
EAX bootstrap-cell ADD
! Store exception record in TIB.
tib-exception-list-offset [] EAX FS MOV ;
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
call

52
basis/cpu/x86/64/64.factor
View File

@ -38,26 +38,30 @@ M: x86.64 machine-registers
} ;
: vm-reg ( -- reg ) R13 ; inline
: nv-reg ( -- reg ) RBX ; inline
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
M: x86.64 %vm-field ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] MOV ;
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
M: x86.64 %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] LEA ;
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
M: x86.64 %prologue ( n -- )
temp-reg -7 [] LEA
temp-reg -7 [RIP+] LEA
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
M: x86.64 %prepare-jump
pic-tail-reg xt-tail-pic-offset [] LEA ;
pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
@ -110,7 +114,7 @@ M: x86.64 %pop-stack ( n -- )
param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- )
temp-reg "ctx" %vm-field
temp-reg %context
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -215,23 +219,20 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %nest-stacks ( -- )
param-reg-0 %mov-vm-ptr
"nest_stacks" f %alien-invoke ;
M: x86.64 %unnest-stacks ( -- )
param-reg-0 %mov-vm-ptr
"unnest_stacks" f %alien-invoke ;
M: x86.64 %prepare-alien-indirect ( -- )
param-reg-0 ds-reg [] MOV
ds-reg 8 SUB
param-reg-1 %mov-vm-ptr
"pinned_alien_offset" f %alien-invoke
RBP RAX MOV ;
nv-reg RAX MOV ;
M: x86.64 %alien-indirect ( -- )
RBP CALL ;
nv-reg CALL ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
param-reg-0 param-reg-1 %restore-context
@ -239,16 +240,15 @@ M: x86.64 %alien-callback ( quot -- )
param-reg-0 quot-entry-point-offset [+] CALL
param-reg-0 param-reg-1 %save-context ;
M: x86.64 %callback-value ( ctype -- )
%pop-context-stack
RSP 8 SUB
param-reg-0 PUSH
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in param-reg-0
param-reg-0 POP
RSP 8 ADD
"end_callback" f %alien-invoke ;
M: x86.64 %end-callback-value ( ctype -- )
%pop-context-stack
nv-reg param-reg-0 MOV
%end-callback
param-reg-0 nv-reg MOV
! Unbox former top of data stack to return registers
unbox-return ;

144
basis/cpu/x86/64/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: bootstrap.image.private kernel kernel.private namespaces
system layouts vocabs parser compiler.constants math
math.private cpu.x86.assembler cpu.x86.assembler.operands
sequences generic.single.private ;
sequences generic.single.private threads.private ;
IN: bootstrap.x86
8 \ cell set
@ -16,7 +16,7 @@ IN: bootstrap.x86
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
: return-reg ( -- reg ) RAX ;
: safe-reg ( -- reg ) RAX ;
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
: ctx-reg ( -- reg ) R12 ;
@ -26,19 +26,28 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
: jit-save-tib ( -- ) ;
: jit-restore-tib ( -- ) ;
: jit-update-tib ( ctx-reg -- ) drop ;
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
: jit-call ( name -- )
RAX 0 MOV rc-absolute-cell jit-dlsym
RAX CALL ;
[
! load entry point
safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
RAX 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push entry point
safe-reg PUSH
RAX PUSH
! alignment
RSP stack-frame-size 3 bootstrap-cells - SUB
] jit-prolog jit-define
[
temp3 5 [] LEA
temp3 5 [RIP+] LEA
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define
@ -47,17 +56,18 @@ IN: bootstrap.x86
: jit-save-context ( -- )
jit-load-context
safe-reg RSP -8 [+] LEA
ctx-reg context-callstack-top-offset [+] safe-reg MOV
R11 RSP -8 [+] LEA
ctx-reg context-callstack-top-offset [+] R11 MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
jit-load-context
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
jit-save-context
! call the primitive
arg1 vm-reg MOV
@ -66,22 +76,34 @@ IN: bootstrap.x86
jit-restore-context
] jit-primitive jit-define
: jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ;
: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
[
arg2 arg1 MOV
arg1 vm-reg MOV
"begin_callback" jit-call
jit-load-context
jit-restore-context
! save ctx->callstack_bottom
safe-reg stack-reg stack-frame-size 8 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
! call the quotation
arg1 quot-entry-point-offset [+] CALL
arg1 return-reg MOV
jit-call-quot
jit-save-context
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
arg1 ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
[ arg1 quot-entry-point-offset [+] CALL ]
[ arg1 quot-entry-point-offset [+] JMP ]
[ jit-call-quot ]
[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
@ -99,10 +121,11 @@ IN: bootstrap.x86
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
! Load ds and rs registers
jit-load-context
jit-restore-context
! Call quotation
arg1 quot-entry-point-offset [+] JMP
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
@ -124,8 +147,7 @@ IN: bootstrap.x86
! Call memcpy; arguments are now in the correct registers
! Create register shadow area for Win64
RSP 32 SUB
safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
safe-reg CALL
"factor_memcpy" jit-call
! Tear down register shadow area
RSP 32 ADD
! Return with new callstack
@ -135,11 +157,11 @@ IN: bootstrap.x86
[
jit-save-context
arg2 vm-reg MOV
safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
safe-reg CALL
"lazy_jit_compile" jit-call
arg1 return-reg MOV
]
[ return-reg quot-entry-point-offset [+] CALL ]
[ return-reg quot-entry-point-offset [+] JMP ]
[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
@ -152,8 +174,8 @@ IN: bootstrap.x86
jit-save-context
arg1 RBX MOV
arg2 vm-reg MOV
RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
RAX CALL
"inline_cache_miss" jit-call
jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
@ -176,11 +198,7 @@ IN: bootstrap.x86
[ [ arg3 arg2 ] dip call ] dip
ds-reg [] arg3 MOV
[ JNO ]
[
arg3 vm-reg MOV
RAX 0 MOV f rc-absolute-cell jit-dlsym
RAX CALL
]
[ arg3 vm-reg MOV jit-call ]
jit-conditional ; inline
[ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
@ -202,11 +220,79 @@ IN: bootstrap.x86
arg1 tag-bits get SAR
arg2 RBX MOV
arg3 vm-reg MOV
RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
RAX CALL
"overflow_fixnum_multiply" jit-call
]
jit-conditional
] \ fixnum* define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-save-context
! Make the new context the current one
ctx-reg swap MOV
vm-reg vm-context-offset [+] ctx-reg MOV
! Load new stack pointer
RSP ctx-reg context-callstack-top-offset [+] MOV
! Load new ds, rs registers
jit-restore-context ;
: jit-pop-context-and-param ( -- )
arg1 ds-reg [] MOV
arg1 arg1 alien-offset [+] MOV
arg2 ds-reg -8 [+] MOV
ds-reg 16 SUB ;
: jit-push-param ( -- )
ds-reg 8 ADD
ds-reg [] arg2 MOV ;
: jit-set-context ( -- )
jit-pop-context-and-param
arg1 jit-switch-context
RSP 8 ADD
jit-push-param ;
[ jit-set-context ] \ (set-context) define-sub-primitive
: jit-pop-quot-and-param ( -- )
arg1 ds-reg [] MOV
arg2 ds-reg -8 [+] MOV
ds-reg 16 SUB ;
: jit-start-context ( -- )
! Create the new context in return-reg
arg1 vm-reg MOV
"new_context" jit-call
jit-pop-quot-and-param
return-reg jit-switch-context
jit-push-param
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-context
arg1 vm-reg MOV
arg2 ctx-reg MOV
"delete_context" jit-call ;
[
jit-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
[
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call

10
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,5 +1,5 @@
USING: cpu.x86.assembler cpu.x86.assembler.operands
kernel tools.test namespaces make ;
kernel tools.test namespaces make layouts ;
IN: cpu.x86.assembler.tests
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
@ -164,3 +164,11 @@ IN: cpu.x86.assembler.tests
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
bootstrap-cell 4 = [
[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test
] when
bootstrap-cell 8 = [
[ { 72 137 13 123 0 0 0 } ] [ [ 123 [RIP+] RCX MOV ] { } make ] unit-test
[ { 101 72 137 12 37 123 0 0 0 } ] [ [ 123 [] GS RCX MOV ] { } make ] unit-test
] when

23
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators kernel.private math
math.bitwise locals namespaces make sequences words system
layouts math.order accessors cpu.x86.assembler.operands
cpu.x86.assembler.operands.private ;
USING: arrays io.binary kernel combinators
combinators.short-circuit math math.bitwise locals namespaces
make sequences words system layouts math.order accessors
cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
QUALIFIED: sequences
IN: cpu.x86.assembler
@ -22,7 +22,11 @@ IN: cpu.x86.assembler
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
[ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
{
[ base>> { ESP RSP R12 } member? ]
[ index>> ]
[ scale>> ]
} 1|| ;
M: register sib-present? drop f ;
@ -188,6 +192,13 @@ M: register displacement, drop ;
PRIVATE>
! Segment override prefixes
: CS ( -- ) HEX: 2e , ;
: ES ( -- ) HEX: 26 , ;
: SS ( -- ) HEX: 36 , ;
: FS ( -- ) HEX: 64 , ;
: GS ( -- ) HEX: 65 , ;
! Moving stuff
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;

14
basis/cpu/x86/assembler/operands/operands.factor
View File

@ -1,13 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff.
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words math accessors sequences namespaces
assocs layouts cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler.operands
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
@ -90,7 +86,13 @@ M: object operand-64? drop f ;
PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
dup integer?
[ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
[ f f f <indirect> ]
if ;
: [RIP+] ( displacement -- indirect )
[ f f f ] dip <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?

59
basis/cpu/x86/bootstrap.factor
View File

@ -13,37 +13,54 @@ big-endian off
! Optimizing compiler's side of callback accesses
! arguments that are on the stack via the frame pointer.
! On x86-64, some arguments are passed in registers, and
! so the only register that is safe for use here is safe-reg.
! so the only register that is safe for use here is nv-reg.
frame-reg PUSH
frame-reg stack-reg MOV
! Save all non-volatile registers
nv-regs [ PUSH ] each
! Save old stack pointer and align
safe-reg stack-reg MOV
stack-reg bootstrap-cell SUB
stack-reg -16 AND
stack-reg [] safe-reg MOV
! Register shadow area - only required on Win64, but doesn't
! hurt on other platforms
stack-reg 32 SUB
jit-save-tib
! Load VM into vm-reg
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
! Save old context
nv-reg vm-reg vm-context-offset [+] MOV
nv-reg PUSH
! Switch over to the spare context
nv-reg vm-reg vm-spare-context-offset [+] MOV
vm-reg vm-context-offset [+] nv-reg MOV
! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV
! Load Factor callstack pointer
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
nv-reg jit-update-tib
jit-install-seh
! Call into Factor code
safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
safe-reg CALL
nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
nv-reg CALL
! Tear down register shadow area
stack-reg 32 ADD
! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
! Undo stack alignment
stack-reg stack-reg [] MOV
! Load C callstack pointer
nv-reg vm-reg vm-context-offset [+] MOV
stack-reg nv-reg context-callstack-save-offset [+] MOV
! Load old context
nv-reg POP
vm-reg vm-context-offset [+] nv-reg MOV
! Restore non-volatile registers
jit-restore-tib
nv-regs <reversed> [ POP ] each
frame-reg POP
@ -56,15 +73,15 @@ big-endian off
[
! Load word
safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel
! Bump profiling counter
safe-reg profile-count-offset [+] 1 tag-fixnum ADD
nv-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
safe-reg safe-reg word-code-offset [+] MOV
nv-reg nv-reg word-code-offset [+] MOV
! Compute word entry point
safe-reg compiled-header-size ADD
nv-reg compiled-header-size ADD
! Jump to entry point
safe-reg JMP
nv-reg JMP
] jit-profiling jit-define
[

18
basis/cpu/x86/x86.factor
View File

@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
HOOK: %mov-vm-ptr cpu ( reg -- )
HOOK: %vm-field-ptr cpu ( reg offset -- )
: load-zone-offset ( nursery-ptr -- )
"nursery" vm-field-offset %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
[ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ [] ] dip data-alignment get align ADD ;
@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %check-nursery ( label size temp1 temp2 -- )
temp1 "nursery" %vm-field-ptr
temp1 load-zone-offset
! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- )
temp-reg "ctx" %vm-field
temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ;
@ -1403,10 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
#! Also save callstack bottom!
temp1 "ctx" %vm-field
temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
temp1 %context
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
@ -1414,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
temp1 "ctx" %vm-field
temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV

8
basis/debugger/debugger.factor
View File

@ -120,6 +120,8 @@ HOOK: signal-error. os ( obj -- )
: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
: callstack-underflow. ( obj -- ) "Call" stack-underflow. ;
: callstack-overflow. ( obj -- ) "Call" stack-overflow. ;
: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
@ -153,8 +155,10 @@ PREDICATE: vm-error < array
{ 11 [ datastack-overflow. ] }
{ 12 [ retainstack-underflow. ] }
{ 13 [ retainstack-overflow. ] }
{ 14 [ memory-error. ] }
{ 15 [ fp-trap-error. ] }
{ 14 [ callstack-underflow. ] }
{ 15 [ callstack-overflow. ] }
{ 16 [ memory-error. ] }
{ 17 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;

16
basis/delegate/delegate-docs.factor
View File

@ -18,9 +18,16 @@ HELP: define-consult
{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT:
{ $syntax "CONSULT: group class getter... ;" }
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
{ $syntax """CONSULT: group class
code ;""" }
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } }
{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "CONSULT:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "CONSULT:" } " to override the delegation." } ;
HELP: BROADCAST:
{ $syntax """BROADCAST: group class
code ;""" }
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } }
{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to every object in the sequence returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "BROADCAST:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "BROADCAST:" } " to override the delegation. Every generic word in " { $snippet "group" } " must return no outputs; otherwise, a " { $link broadcast-words-must-have-no-outputs } " error will be raised." } ;
HELP: SLOT-PROTOCOL:
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
@ -28,7 +35,7 @@ HELP: SLOT-PROTOCOL:
{ define-protocol POSTPONE: PROTOCOL: } related-words
{ define-consult POSTPONE: CONSULT: } related-words
{ define-consult POSTPONE: BROADCAST: POSTPONE: CONSULT: } related-words
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
@ -52,6 +59,7 @@ $nl
{ $subsections POSTPONE: SLOT-PROTOCOL: }
"Defining consultation:"
{ $subsections
POSTPONE: BROADCAST:
POSTPONE: CONSULT:
define-consult
}

17
basis/delegate/delegate-tests.factor
View File

@ -1,7 +1,7 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.single delegate.protocols
delegate.private assocs see ;
delegate.private assocs see make ;
IN: delegate.tests
TUPLE: hello this that ;
@ -197,3 +197,18 @@ DEFER: seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
] unit-test
GENERIC: broadcastable ( x -- )
GENERIC: nonbroadcastable ( x -- y )
TUPLE: broadcaster targets ;
BROADCAST: broadcastable broadcaster targets>> ;
M: integer broadcastable 1 + , ;
[ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ]
[ error>> broadcast-words-must-have-no-outputs? ] must-fail-with
[ { 2 3 4 } ]
[ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test

31
basis/delegate/delegate.factor
View File

@ -1,12 +1,14 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg
! Portions copyright (C) 2009 Slava Pestov
! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions generic
USING: accessors arrays assocs classes.tuple definitions effects generic
generic.standard hashtables kernel lexer math parser
generic.parser sequences sets slots words words.symbol fry
compiler.units ;
IN: delegate
ERROR: broadcast-words-must-have-no-outputs group ;
<PRIVATE
: protocol-words ( protocol -- words )
@ -28,12 +30,19 @@ M: tuple-class group-words
2array
] map concat ;
: check-broadcast-group ( group -- group )
dup group-words [ first stack-effect out>> empty? ] all?
[ broadcast-words-must-have-no-outputs ] unless ;
! Consultation
TUPLE: consultation group class quot loc ;
TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
f consultation boa ;
: <broadcast> ( group class quot -- consultation )
[ check-broadcast-group ] 2dip f broadcast boa ;
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep
@ -44,13 +53,21 @@ PREDICATE: consult-method < method "consultation" word-prop ;
M: consult-method reset-word
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
: consult-method-quot ( quot word -- object )
GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
M: consultation (consult-method-quot)
'[ _ call _ execute ] nip ;
M: broadcast (consult-method-quot)
'[ _ call [ _ execute ] each ] nip ;
: consult-method-quot ( consultation word -- object )
[ dup quot>> ] dip
[ second [ [ dip ] curry ] times ] [ first ] bi
'[ _ call _ execute ] ;
(consult-method-quot) ;
: consult-method ( word consultation -- )
[ create-consult-method ]
[ quot>> swap consult-method-quot ] 2bi
[ swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
@ -89,6 +106,10 @@ SYNTAX: CONSULT:
scan-word scan-word parse-definition <consultation>
[ save-location ] [ define-consult ] bi ;
SYNTAX: BROADCAST:
scan-word scan-word parse-definition <broadcast>
[ save-location ] [ define-consult ] bi ;
M: consultation where loc>> ;
M: consultation set-where (>>loc) ;

10
basis/deques/deques.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math fry ;
IN: deques
@ -16,22 +16,22 @@ GENERIC: node-value ( node -- value )
GENERIC: deque-empty? ( deque -- ? )
: push-front ( obj deque -- )
push-front* drop ;
push-front* drop ; inline
: push-all-front ( seq deque -- )
[ push-front ] curry each ;
: push-back ( obj deque -- )
push-back* drop ;
push-back* drop ; inline
: push-all-back ( seq deque -- )
[ push-back ] curry each ;
: pop-front ( deque -- obj )
[ peek-front ] [ pop-front* ] bi ;
[ peek-front ] [ pop-front* ] bi ; inline
: pop-back ( deque -- obj )
[ peek-back ] [ pop-back* ] bi ;
[ peek-back ] [ pop-back* ] bi ; inline
: slurp-deque ( deque quot -- )
[ drop '[ _ deque-empty? not ] ]

2
basis/dlists/dlists.factor
View File

@ -29,7 +29,7 @@ TUPLE: dlist
: <hashed-dlist> ( -- search-deque )
20 <hashtable> <dlist> <search-deque> ;
M: dlist deque-empty? front>> not ;
M: dlist deque-empty? front>> not ; inline
M: dlist-node node-value obj>> ;

2
basis/heaps/heaps.factor
View File

@ -35,7 +35,7 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? )
data>> empty? ;
data>> empty? ; inline
M: heap heap-size ( heap -- n )
data>> length ;

2
basis/http/client/client.factor
View File

@ -196,4 +196,4 @@ ERROR: download-failed response ;
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when
"debugger" "http.client.debugger" require-when

6
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -3,7 +3,7 @@
USING: accessors alien.c-types combinators destructors
io.backend.unix kernel math.bitwise sequences
specialized-arrays unix unix.kqueue unix.time assocs
io.backend.unix.multiplexers classes.struct ;
io.backend.unix.multiplexers classes.struct literals ;
SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
@ -31,13 +31,13 @@ M: kqueue-mx dispose* fd>> close-file ;
M: kqueue-mx add-input-callback ( thread fd mx -- )
[ call-next-method ] [
[ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
[ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
M: kqueue-mx add-output-callback ( thread fd mx -- )
[ call-next-method ] [
[ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
[ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;

5
basis/io/backend/unix/unix.factor
View File

@ -67,12 +67,11 @@ M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
'[
swap handle-fd mx get-global _ {
[ [ self ] dip handle-fd mx get-global ] dip {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] "I/O" suspend nip [ io-timeout ] when
"I/O" suspend [ io-timeout ] when
] if ;
: wait-for-port ( port event -- )

4
basis/io/backend/windows/nt/nt.factor
View File

@ -40,8 +40,8 @@ M: winnt add-completion ( win32-handle -- )
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
[ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
{
[ self ] dip >c-ptr pending-overlapped get-global set-at
"I/O" suspend {
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?

4
basis/io/backend/windows/nt/privileges/privileges.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types alien.data alien.syntax arrays continuations
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc locals math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
io.backend.windows.privileges classes.struct windows.errors ;
io.backend.windows.privileges classes.struct windows.errors literals ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@ -11,7 +11,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )

8
basis/io/backend/windows/windows.factor
View File

@ -5,7 +5,7 @@ io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types splitting
continuations math.bitwise accessors init sets assocs
classes.struct classes ;
classes.struct classes literals ;
IN: io.backend.windows
TUPLE: win32-handle < disposable handle ;
@ -43,12 +43,12 @@ HOOK: add-completion io-backend ( port -- )
<win32-file> |dispose
dup add-completion ;
: share-mode ( -- n )
{
CONSTANT: share-mode
flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
} flags ; foldable
}
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>

5
basis/io/directories/unix/unix.factor
View File

@ -4,11 +4,10 @@ USING: accessors alien.c-types alien.strings combinators
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
unix unix.stat vocabs.loader classes.struct unix.ffi ;
unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
IN: io.directories.unix
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
M: unix touch-file ( path -- )
normalize-path

20
basis/io/files/unique/unique-docs.factor
View File

@ -54,12 +54,19 @@ HELP: with-unique-directory
}
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
HELP: move-file-unique
HELP: copy-file-unique
{ $values
{ "path" "a pathname string" } { "directory" "a directory" }
{ "path" "a pathname string" } { "prefix" string } { "suffix" string }
{ "path'" "a pathname string" }
}
{ $description "Moves " { $snippet "path" } " to " { $snippet "directory" } " by creating a unique file in this directory. Returns the new path." } ;
{ $description "Copies " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
HELP: move-file-unique
{ $values
{ "path" "a pathname string" } { "prefix" string } { "suffix" string }
{ "path'" "a pathname string" }
}
{ $description "Moves " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
HELP: current-temporary-directory
{ $values
@ -98,7 +105,10 @@ ARTICLE: "io.files.unique" "Unique files"
}
"Default temporary directory:"
{ $subsections default-temporary-directory }
"Moving files into a directory safely:"
{ $subsections move-file-unique } ;
"Copying and moving files to a new unique file:"
{ $subsections
copy-file-unique
move-file-unique
} ;
ABOUT: "io.files.unique"

15
basis/io/files/unique/unique.factor
View File

@ -70,10 +70,17 @@ PRIVATE>
: unique-file ( prefix -- path )
"" make-unique-file ;
: move-file-unique ( path directory -- path' )
[
"" unique-file [ move-file ] keep
] with-temporary-directory ;
: move-file-unique ( path prefix suffix -- path' )
make-unique-file [ move-file ] keep ;
: copy-file-unique ( path prefix suffix -- path' )
make-unique-file [ copy-file ] keep ;
: temporary-file ( -- path ) "" unique-file ;
: with-working-directory ( path quot -- )
over make-directories
dupd '[ _ _ with-temporary-directory ] with-directory ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }

5
basis/io/files/unique/unix/unix.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise
unix system io.files.unique unix.ffi ;
unix system io.files.unique unix.ffi literals ;
IN: io.files.unique.unix
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ;

6
basis/io/files/unix/unix-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences
grouping io.pathnames.private ;
grouping io.pathnames.private literals ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
@ -45,7 +45,7 @@ IN: io.files.unix.tests
prepare-test-file
[ t ]
[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test
[ t ] [ test-file user-read? ] unit-test
[ t ] [ test-file user-write? ] unit-test
@ -85,7 +85,7 @@ prepare-test-file
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test
prepare-test-file

12
basis/io/files/unix/unix.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: unix byte-arrays kernel io.backend.unix math.bitwise
io.ports io.files io.files.private io.pathnames environment
destructors system unix.ffi ;
destructors system unix.ffi literals ;
IN: io.files.unix
M: unix cwd ( -- path )
@ -12,15 +12,14 @@ M: unix cwd ( -- path )
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: read-flags ( -- n ) O_RDONLY ; inline
CONSTANT: read-flags flags{ O_RDONLY }
: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
: open-read ( path -- fd ) read-flags file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <fd> init-fd <input-port> ;
: write-flags ( -- n )
{ O_WRONLY O_CREAT O_TRUNC } flags ; inline
CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
: open-write ( path -- fd )
write-flags file-mode open-file ;
@ -28,8 +27,7 @@ M: unix (file-reader) ( path -- stream )
M: unix (file-writer) ( path -- stream )
open-write <fd> init-fd <output-port> ;
: append-flags ( -- n )
{ O_WRONLY O_APPEND O_CREAT } flags ; inline
CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
: open-append ( path -- fd )
[

9
basis/io/files/windows/windows.factor
View File

@ -6,7 +6,8 @@ io.backend.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time windows.types calendar
combinators math.functions sequences namespaces make words
system destructors accessors math.bitwise continuations
windows.errors arrays byte-arrays generalizations alien.data ;
windows.errors arrays byte-arrays generalizations alien.data
literals ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )
@ -16,7 +17,7 @@ IN: io.files.windows
] with-destructors ;
: open-r/w ( path -- win32-file )
{ GENERIC_READ GENERIC_WRITE } flags
flags{ GENERIC_READ GENERIC_WRITE }
OPEN_EXISTING 0 open-file ;
: open-read ( path -- win32-file )
@ -29,7 +30,7 @@ IN: io.files.windows
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: open-existing ( path -- win32-file )
{ GENERIC_READ GENERIC_WRITE } flags
flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_EXISTING
@ -38,7 +39,7 @@ IN: io.files.windows
: maybe-create-file ( path -- win32-file ? )
#! return true if file was just created
{ GENERIC_READ GENERIC_WRITE } flags
flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_ALWAYS

8
basis/io/launcher/launcher.factor
View File

@ -129,12 +129,8 @@ M: process-was-killed error.
: (wait-for-process) ( process -- status )
dup handle>>
[
dup [ processes get at push ] curry
"process" suspend drop
] when
dup killed>>
[ process-was-killed ] [ status>> ] if ;
[ self over processes get at push "process" suspend drop ] when
dup killed>> [ process-was-killed ] [ status>> ] if ;
: wait-for-process ( process -- status )
[ (wait-for-process) ] with-timeout ;

10
basis/io/mmap/unix/unix.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors destructors io.backend.unix io.mmap
USING: accessors destructors io.backend.unix io.mmap literals
io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
IN: io.mmap.unix
@ -12,13 +12,13 @@ IN: io.mmap.unix
] with-destructors ;
M: unix (mapped-file-r/w)
{ PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags
flags{ PROT_READ PROT_WRITE }
flags{ MAP_FILE MAP_SHARED }
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
{ PROT_READ } flags
{ MAP_FILE MAP_SHARED } flags
flags{ PROT_READ }
flags{ MAP_FILE MAP_SHARED }
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )

8
basis/io/mmap/windows/windows.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
accessors locals windows.errors ;
accessors locals windows.errors literals ;
IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
@ -29,9 +29,9 @@ C: <win32-mapped-file> win32-mapped-file
M: windows (mapped-file-r/w)
[
{ GENERIC_WRITE GENERIC_READ } flags
flags{ GENERIC_WRITE GENERIC_READ }
OPEN_ALWAYS
{ PAGE_READWRITE SEC_COMMIT } flags
flags{ PAGE_READWRITE SEC_COMMIT }
FILE_MAP_ALL_ACCESS mmap-open
-rot <win32-mapped-file>
] with-destructors ;
@ -40,7 +40,7 @@ M: windows (mapped-file-reader)
[
GENERIC_READ
OPEN_ALWAYS
{ PAGE_READONLY SEC_COMMIT } flags
flags{ PAGE_READONLY SEC_COMMIT }
FILE_MAP_READ mmap-open
-rot <win32-mapped-file>
] with-destructors ;

6
basis/io/monitors/linux/linux.factor
View File

@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
system hashtables destructors unix classes.struct ;
system hashtables destructors unix classes.struct literals ;
FROM: namespaces => set ;
IN: io.monitors.linux
@ -65,13 +65,13 @@ M: linux-monitor dispose* ( monitor -- )
tri ;
: ignore-flags? ( mask -- ? )
{
flags{
IN_DELETE_SELF
IN_MOVE_SELF
IN_UNMOUNT
IN_Q_OVERFLOW
IN_IGNORED
} flags bitand 0 > ;
} bitand 0 > ;
: parse-action ( mask -- changed )
[

4
basis/io/monitors/windows/nt/nt.factor
View File

@ -5,7 +5,7 @@ locals kernel math assocs namespaces make continuations sequences
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string
io.buffers io.files io.timeouts io.encodings.string literals
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
@ -16,7 +16,7 @@ IN: io.monitors.windows.nt
share-mode
f
OPEN_EXISTING
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
f
CreateFile opened-file ;

6
basis/io/pipes/windows/nt/nt.factor
View File

@ -3,14 +3,14 @@
USING: alien alien.c-types arrays destructors io io.backend.windows libc
windows.types math.bitwise windows.kernel32 windows namespaces
make kernel sequences windows.errors assocs math.parser system
random combinators accessors io.pipes io.ports ;
random combinators accessors io.pipes io.ports literals ;
IN: io.pipes.windows.nt
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: create-named-pipe ( name -- handle )
{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
PIPE_TYPE_BYTE
1
4096
@ -21,7 +21,7 @@ IN: io.pipes.windows.nt
: open-other-end ( name -- handle )
GENERIC_WRITE
{ FILE_SHARE_READ FILE_SHARE_WRITE } flags
flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
default-security-attributes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED

4
basis/libc/libc-docs.factor
View File

@ -32,6 +32,10 @@ HELP: free
{ $values { "alien" c-ptr } }
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
HELP: (free)
{ $values { "alien" c-ptr } }
{ $description "Deallocates a block of memory allocated by an external C library." } ;
HELP: &free
{ $values { "alien" c-ptr } }
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;

6
basis/libc/libc.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Mackenzie Straight
! Copyright (C) 2007, 2009 Slava Pestov
! Copyright (C) 2007, 2010 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types assocs continuations alien.destructors kernel
@ -18,8 +18,6 @@ IN: libc
: preserve-errno ( quot -- )
errno [ call ] dip set-errno ; inline
<PRIVATE
: (malloc) ( size -- alien )
void* "libc" "malloc" { ulong } alien-invoke ;
@ -32,6 +30,8 @@ IN: libc
: (realloc) ( alien size -- newalien )
void* "libc" "realloc" { void* ulong } alien-invoke ;
<PRIVATE
! We stick malloc-ptr instances in the global disposables set
TUPLE: malloc-ptr value continuation ;

15
basis/literals/literals-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel multiline ;
USING: help.markup help.syntax kernel multiline sequences ;
IN: literals
HELP: $
@ -62,6 +62,19 @@ ${ five six 7 } .
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
HELP: flags{
{ $values { "values" sequence } }
{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
{ $examples
{ $example "USING: literals kernel prettyprint ;"
"IN: scratchpad"
"CONSTANT: x HEX: 1"
"flags{ HEX: 20 x BIN: 100 } .h"
"25"
}
} ;
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example """

15
basis/literals/literals-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel literals math tools.test ;
USING: accessors kernel literals math tools.test ;
IN: literals.tests
<<
@ -27,3 +27,16 @@ CONSTANT: constant-a 3
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
CONSTANT: a 1
CONSTANT: b 2
ALIAS: c b
ALIAS: d c
CONSTANT: foo flags{ a b d }
[ 3 ] [ foo ] unit-test
[ 3 ] [ flags{ a b d } ] unit-test
\ foo def>> must-infer
[ 1 ] [ flags{ 1 } ] unit-test

16
basis/literals/literals.factor
View File

@ -1,6 +1,6 @@
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations
vectors sequences fry ;
USING: accessors combinators continuations fry kernel lexer
math parser quotations sequences vectors words words.alias ;
IN: literals
<PRIVATE
@ -8,8 +8,13 @@ IN: literals
! Use def>> call so that CONSTANT:s defined in the same file can
! be called
: expand-alias ( obj -- obj' )
dup alias? [ def>> first expand-alias ] when ;
: expand-literal ( seq obj -- seq' )
'[ _ dup word? [ def>> call ] when ] with-datastack ;
'[
_ expand-alias dup word? [ def>> call ] when
] with-datastack ;
: expand-literals ( seq -- seq' )
[ [ { } ] dip expand-literal ] map concat ;
@ -19,3 +24,8 @@ PRIVATE>
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
SYNTAX: flags{
\ } [
expand-literals
0 [ bitor ] reduce
] parse-literal ;

5
basis/locals/errors/errors.factor
View File

@ -19,11 +19,6 @@ ERROR: local-writer-in-literal-error ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
ERROR: local-word-in-literal-error ;
M: local-word-in-literal-error summary
drop "Local words not permitted inside literals" ;
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary

6
basis/locals/locals.factor
View File

@ -26,7 +26,5 @@ SYNTAX: MEMO:: (::) define-memoized ;
"locals.fry"
} [ require ] each
"prettyprint" vocab [
"locals.definitions" require
"locals.prettyprint" require
] when
"prettyprint" "locals.definitions" require-when
"prettyprint" "locals.prettyprint" require-when

4
basis/locals/parser/parser.factor
View File

@ -24,10 +24,6 @@ SYMBOL: in-lambda?
: parse-local-defs ( -- words assoc )
[ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
SINGLETON: lambda-parser
SYMBOL: locals

2
basis/locals/rewrite/point-free/point-free.factor
View File

@ -21,8 +21,6 @@ M: local localize dupd read-local-quot ;
M: quote localize dupd local>> read-local-quot ;
M: local-word localize dupd read-local-quot [ call ] append ;
M: local-reader localize dupd read-local-quot [ local-value ] append ;
M: local-writer localize

3
basis/locals/rewrite/sugar/sugar.factor
View File

@ -82,9 +82,6 @@ M: local-reader rewrite-element , ;
M: local-writer rewrite-element
local-writer-in-literal-error ;
M: local-word rewrite-element
local-word-in-literal-error ;
M: word rewrite-element <wrapper> , ;
: rewrite-wrapper ( wrapper -- )

9
basis/locals/types/types.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! Copyright (C) 2007, 2010 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel sequences words
quotations ;
@ -35,11 +35,6 @@ PREDICATE: local < word "local?" word-prop ;
M: local literalize ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
@ -58,5 +53,5 @@ PREDICATE: local-writer < word "local-writer?" word-prop ;
[ nip ]
} 2cleave ;
UNION: lexical local local-reader local-writer local-word ;
UNION: lexical local local-reader local-writer ;
UNION: special lexical quote def ;

17
basis/math/bitwise/bitwise-docs.factor
View File

@ -135,18 +135,6 @@ HELP: clear-bit
}
} ;
HELP: flags
{ $values { "values" sequence } }
{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
{ $examples
{ $example "USING: math.bitwise kernel prettyprint ;"
"IN: scratchpad"
"CONSTANT: x HEX: 1"
"{ HEX: 20 x BIN: 100 } flags .h"
"25"
}
} ;
HELP: symbols>flags
{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
@ -375,6 +363,10 @@ $nl
bit?
bit-clear?
}
"Toggling a bit:"
{ $subsections
toggle-bit
}
"Operations with bitmasks:"
{ $subsections
mask
@ -404,7 +396,6 @@ $nl
}
"Bitfields:"
{ $subsections
flags
"math-bitfields"
} ;

13
basis/math/bitwise/bitwise-tests.factor
View File

@ -1,6 +1,6 @@
USING: accessors math math.bitwise tools.test kernel words
specialized-arrays alien.c-types math.vectors.simd
sequences destructors libc ;
sequences destructors libc literals ;
SPECIALIZED-ARRAY: int
IN: math.bitwise.tests
@ -23,17 +23,6 @@ IN: math.bitwise.tests
: test-1+ ( x -- y ) 1 + ;
[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
CONSTANT: a 1
CONSTANT: b 2
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test

4
basis/math/bitwise/bitwise.factor
View File

@ -44,10 +44,6 @@ IN: math.bitwise
: W- ( x y -- z ) - 64 bits ; inline
: W* ( x y -- z ) * 64 bits ; inline
! flags
MACRO: flags ( values -- )
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
: symbols>flags ( symbols assoc -- flag-bits )
[ at ] curry map
0 [ bitor ] reduce ;

4
basis/math/rectangles/rectangles.factor
View File

@ -62,6 +62,6 @@ M: rect contains-point?
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
USING: vocabs vocabs.loader ;
USE: vocabs.loader
"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
"prettyprint" "math.rectangles.prettyprint" require-when

4
basis/math/vectors/simd/simd.factor
View File

@ -339,6 +339,4 @@ M: short-8 v*hs+
M: int-4 v*hs+
int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
"mirrors" vocab [
"math.vectors.simd.mirrors" require
] when
"mirrors" "math.vectors.simd.mirrors" require-when

4
basis/mirrors/mirrors.factor
View File

@ -59,7 +59,3 @@ M: hashtable make-mirror ;
M: integer make-mirror drop f ;
M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
"specialized-arrays" vocab [
"specialized-arrays.mirrors" require
] when

2
basis/models/product/product-docs.factor
View File

@ -13,7 +13,7 @@ $nl
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"
"ui.gadgets.sliders ;"
""
": <funny-model> ( -- model ) 0 10 0 100 <range> ;"
": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"
": <funny-slider> ( model -- slider ) horizontal <slider> ;"
""
"<funny-model> <funny-model> 2array"

9
basis/openssl/libssl/libssl.factor
View File

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax combinators kernel
system namespaces assocs parser lexer sequences words
quotations math.bitwise alien.libraries ;
quotations math.bitwise alien.libraries literals ;
IN: openssl.libssl
@ -258,15 +258,14 @@ CONSTANT: SSL_SESS_CACHE_OFF HEX: 0000
CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
: SSL_SESS_CACHE_BOTH ( -- n )
{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER }
CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL
flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE }
! ===============================================
! x509_vfy.h

4
basis/peg/peg.factor
View File

@ -630,6 +630,4 @@ SYNTAX: PEG:
USING: vocabs vocabs.loader ;
"debugger" vocab [
"peg.debugger" require
] when
"debugger" "peg.debugger" require-when

2
basis/random/windows/windows.factor
View File

@ -36,7 +36,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
] if ;
: create-crypto-context ( provider type -- handle )
{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET }
(acquire-crypto-context) win32-error=0/f *void* ;
ERROR: acquire-crypto-context-failed provider type ;

2
basis/regexp/parser/parser.factor
View File

@ -133,7 +133,7 @@ CharacterInBracket = !("}") Character
QuotedCharacter = !("\\E") .
Escape = "p{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> ]]
| "P{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> <negation> ]]
| "P{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> <not-class> ]]
| "Q" QuotedCharacter*:s "\\E" => [[ s <concatenation> ]]
| "u" Character:a Character:b Character:c Character:d
=> [[ { a b c d } hex> ensure-number ]]

5
basis/regexp/regexp-tests.factor
View File

@ -530,3 +530,8 @@ IN: regexp-tests
[ f ] [ "π" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
[ t ] [ "A" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
[ f ] [ "3" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
[ t ] [ " " R/ \P{alpha}/ matches? ] unit-test
[ f ] [ "" R/ \P{alpha}/ matches? ] unit-test
[ f ] [ "a " R/ \P{alpha}/ matches? ] unit-test
[ f ] [ "a" R/ \P{alpha}/ matches? ] unit-test

4
basis/regexp/regexp.factor
View File

@ -218,6 +218,4 @@ SYNTAX: R| CHAR: | parsing-regexp ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [
"regexp.prettyprint" require
] when
"prettyprint" "regexp.prettyprint" require-when

8
basis/specialized-arrays/specialized-arrays.factor
View File

@ -173,10 +173,6 @@ SYNTAX: SPECIALIZED-ARRAYS:
SYNTAX: SPECIALIZED-ARRAY:
scan-c-type define-array-vocab use-vocab ;
"prettyprint" vocab [
"specialized-arrays.prettyprint" require
] when
"prettyprint" "specialized-arrays.prettyprint" require-when
"mirrors" vocab [
"specialized-arrays.mirrors" require
] when
"mirrors" "specialized-arrays.mirrors" require-when

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