DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
+ vm/callstack.o \
+ vm/code_block.o \
+ vm/code_gc.o \
vm/code_heap.o \
+ vm/data_gc.o \
+ vm/data_heap.o \
vm/debug.o \
+ vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
- vm/data_gc.o \
- vm/code_gc.o \
vm/primitives.o \
+ vm/profiler.o \
+ vm/quotations.o \
vm/run.o \
- vm/callstack.o \
vm/types.o \
- vm/quotations.o \
- vm/utilities.o \
- vm/errors.o \
- vm/profiler.o
+ vm/utilities.o
EXE_OBJS = $(PLAF_EXE_OBJS)
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
- dup compiled>> [ execute ] [ drop f ] if ; inline
+ dup optimized>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
{ $values { "str" "a string" } { "upper" "a string" } }\r
{ $description "Converts an ASCII string to upper case." } ;\r
\r
-ARTICLE: "ascii" "ASCII character classes"\r
-"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"\r
+ARTICLE: "ascii" "ASCII"\r
+"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."\r
+$nl\r
+"ASCII character classes:"\r
{ $subsection blank? }\r
{ $subsection letter? }\r
{ $subsection LETTER? }\r
{ $subsection control? }\r
{ $subsection quotable? }\r
{ $subsection ascii? }\r
-"ASCII case conversion is also implemented:"\r
+"ASCII case conversion:"\r
{ $subsection ch>lower }\r
{ $subsection ch>upper }\r
{ $subsection >lower }\r
-{ $subsection >upper }\r
-"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;\r
+{ $subsection >upper } ;\r
\r
ABOUT: "ascii"\r
-! Copyright (C) 2005, 2008 Slava Pestov.\r
+! Copyright (C) 2005, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel math math.order sequences\r
-combinators.short-circuit ;\r
+USING: kernel math math.order sequences strings\r
+combinators.short-circuit hints ;\r
IN: ascii\r
\r
: ascii? ( ch -- ? ) 0 127 between? ; inline\r
-\r
: blank? ( ch -- ? ) " \t\n\r" member? ; inline\r
-\r
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline\r
-\r
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline\r
-\r
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline\r
-\r
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline\r
-\r
-: control? ( ch -- ? )\r
- "\0\e\r\n\t\u000008\u00007f" member? ; inline\r
-\r
-: quotable? ( ch -- ? )\r
- dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline\r
-\r
-: Letter? ( ch -- ? )\r
- [ [ letter? ] [ LETTER? ] ] 1|| ;\r
-\r
-: alpha? ( ch -- ? )\r
- [ [ Letter? ] [ digit? ] ] 1|| ;\r
-\r
-: ch>lower ( ch -- lower )\r
- dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;\r
-\r
-: >lower ( str -- lower )\r
- [ ch>lower ] map ;\r
-\r
-: ch>upper ( ch -- upper )\r
- dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;\r
-\r
-: >upper ( str -- upper )\r
- [ ch>upper ] map ;\r
+: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline\r
+: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline\r
+: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline\r
+: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline\r
+: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline\r
+: >lower ( str -- lower ) [ ch>lower ] map ;\r
+: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline\r
+: >upper ( str -- upper ) [ ch>upper ] map ;\r
+\r
+HINTS: >lower string ;\r
+HINTS: >upper string ;
\ No newline at end of file
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
enable-compiler
-: compile-uncompiled ( words -- )
- [ compiled>> not ] filter compile ;
+: compile-unoptimized ( words -- )
+ [ optimized>> not ] filter compile ;
nl
"Compiling..." write flush
wrap probe
namestack*
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
bitand bitor bitxor bitnot
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
new-sequence nth push pop peek flip
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
hashcode* = get set
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
malloc calloc free memcpy
-} compile-uncompiled
+} compile-unoptimized
"." write flush
-{ build-tree } compile-uncompiled
+{ build-tree } compile-unoptimized
"." write flush
-{ optimize-tree } compile-uncompiled
+{ optimize-tree } compile-unoptimized
"." write flush
-{ optimize-cfg } compile-uncompiled
+{ optimize-cfg } compile-unoptimized
"." write flush
-{ (compile) } compile-uncompiled
+{ (compile) } compile-unoptimized
"." write flush
-vocabs [ words compile-uncompiled "." write flush ] each
+vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary
grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private vocabs
vocabs.loader source-files definitions debugger
-quotations.private sequences.private combinators
+quotations.private sequences.private combinators combinators.smart
math.order math.private accessors
-slots.private compiler.units ;
+slots.private compiler.units fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
- [ (objects) ] dip [ obj>> ] prepose cache ; inline
+ [ (objects) ] dip '[ obj>> @ ] cache ; inline
! Constants
SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad )
- { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+ [ [ { } make ] 3dip ] output>array ; inline
: jit-define ( quot rc rt offset name -- )
[ make-jit ] dip set ; inline
array>> '
quotation type-number object tag-number [
emit ! array
- f ' emit ! compiled>>
+ f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object
! Image output
: (write-image) ( image -- )
- bootstrap-cell big-endian get [
- [ >be write ] curry each
- ] [
- [ >le write ] curry each
- ] if ;
+ bootstrap-cell big-endian get
+ [ '[ _ >be write ] each ]
+ [ '[ _ >le write ] each ] if ;
: write-image ( image -- )
"Writing image to " write
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
- [ compiled>> ] count-words " compiled words" print
+ [ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
+USE: unicode
\ No newline at end of file
} cond drop ;
: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
+ dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
[ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
- f 2array 1array t modify-code-heap ;
+ f 2array 1array modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ t ] [ \ xyz compiled>> ] unit-test
+[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled>> ] unit-test
+[ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail
! regression
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
-[ t ] [ \ <tuple>-regression compiled>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
] if
] if ;
-[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
-[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3
USE: tools.test
-[ t ] [ \ expr compiled>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
: hey ( -- ) ;
: there ( -- ) hey ;
-[ t ] [ \ hey compiled>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
-[ f ] [ \ there compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
+[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ good compiled>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
-[ f ] [ \ ugly compiled>> ] unit-test
+[ f ] [ \ good optimized>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
+[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
] unit-test
] times
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-spill-bug optimized>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
16 narray
] if ;
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
-: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
-: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
-: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form
XO: ADD 0 0 266 31
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
-M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
- tuck in-params>>
- [ postgresql-bind-conversion ] with map
+ [ nip ] [
+ in-params>>
+ [ postgresql-bind-conversion ] with map
+ ] 2bi
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
- tuck
- [ [ first ] map ]
- [ all-slots [ name>> ] map ] bi* diff
+ [ nip ] [
+ [ [ first ] map ]
+ [ all-slots [ name>> ] map ] bi* diff
+ ] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
- tuck offset-of-slot slot ;
+ [ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- )
- tuck offset-of-slot set-slot ;
+ [ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math ;
+USING: kernel sequences math fry ;
IN: deques
GENERIC: push-front* ( obj deque -- node )
[ peek-back ] [ pop-back* ] bi ;
: slurp-deque ( deque quot -- )
- [ drop [ deque-empty? not ] curry ]
- [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
+ [ drop '[ _ deque-empty? not ] ]
+ [ '[ _ pop-back @ ] ]
+ 2bi [ ] while ; inline
MIXIN: deque
-! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques
-search-deques summary hashtables ;
+search-deques summary hashtables fry ;
IN: dlists
<PRIVATE
[ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- )
- [ f ] compose dlist-find-node 2drop ; inline
+ '[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
- [ obj>> ] prepose
- dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
+ '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
- [ obj>> ] prepose delete-node-if* drop ; inline
+ '[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>front
drop ;
: dlist-each ( dlist quot -- )
- [ obj>> ] prepose dlist-each-node ; inline
+ '[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
M: dlist clone
- <dlist> [
- [ push-back ] curry dlist-each
- ] keep ;
+ <dlist> [ '[ _ push-back ] dlist-each ] keep ;
INSTANCE: dlist deque
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors ;
+sequences.private accessors fry ;
IN: grouping
<PRIVATE
[ first2-unsafe ] dip call
] [
[ 2 <sliced-clumps> ] dip
- [ first2-unsafe ] prepose all?
+ '[ first2-unsafe @ ] all?
] if
] if ; inline
USING: definitions help help.markup kernel sequences tools.test
-words parser namespaces assocs generic io.streams.string accessors ;
+words parser namespaces assocs generic io.streams.string accessors
+strings math ;
IN: help.markup.tests
TUPLE: blahblah quux ;
[ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym print-topic ] unit-test
+
+[ "a string" ]
+[ [ { $or string } print-element ] with-string-writer ] unit-test
+
+[ "a string or an integer" ]
+[ [ { $or string integer } print-element ] with-string-writer ] unit-test
+
+[ "a string, a fixnum, or an integer" ]
+[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
: $or ( element -- )
dup length {
{ 1 [ first ($instance) ] }
- { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi ] }
+ { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
[
drop
unclip-last
USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences ;
+urls.encoding byte-arrays strings assocs sequences destructors ;
IN: http.client
HELP: download-failed
HELP: http-post
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
-{ $description "Submits a form at a URL." }
+{ $description "Submits an HTTP POST request." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: http-put
+{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
+{ $description "Submits an HTTP PUT request." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: with-http-get
{ $subsection with-http-get }
{ $subsection with-http-request } ;
-ARTICLE: "http.client.post" "POST requests with the HTTP client"
-"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
-{ $subsection http-post }
-{ $subsection <post-request> }
-"Both words take a post data parameter, which can be one of the following:"
+ARTICLE: "http.client.post-data" "HTTP client submission data"
+"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list
- { "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" }
- { "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
+ { "a " { $link byte-array } ": the data is sent the server without further encoding" }
+ { "a " { $link string } ": the data is encoded and then sent as a series of bytes" }
+ { "an " { $link assoc } ": the assoc is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
+ { "an input stream: the contents of the input stream are transmitted to the server without being read entirely into memory - this is useful for large requests" }
{ { $link f } " denotes that there is no post data" }
+ { "a " { $link post-data } " tuple, for additional control" }
+}
+"When passing a stream, you must ensure the stream is closed afterwards. The best way is to use " { $link with-disposal } " or " { $link "destructors" } ". For example,"
+{ $code
+ "\"my-large-post-request.txt\" ascii <file-reader>"
+ "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
} ;
+ARTICLE: "http.client.post" "POST requests with the HTTP client"
+"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
+{ $subsection http-post }
+"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
+{ $subsection <post-request> }
+"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
+
+ARTICLE: "http.client.put" "PUT requests with the HTTP client"
+"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
+{ $subsection http-post }
+"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
+{ $subsection <post-request> }
+"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
+
ARTICLE: "http.client.encoding" "Character encodings and the HTTP client"
"The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server."
$nl
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$nl
-"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
+"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
$nl
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsection "http.client.get" }
{ $subsection "http.client.post" }
+{ $subsection "http.client.put" }
+"Submission data for POST and PUT requests:"
+{ $subsection "http.client.post-data" }
"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
{ $subsection "http.client.encoding" }
{ $subsection "http.client.errors" }
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary
io.streams.duplex fry ascii urls urls.encoding present
-http http.parsers ;
+http http.parsers http.client.post-data ;
IN: http.client
ERROR: too-many-redirects ;
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
-: set-post-data-headers ( header post-data -- header )
- [
- data>> dup sequence?
- [ length "content-length" ]
- [ drop "chunked" "transfer-encoding" ] if
- pick set-at
- ] [ content-type>> "content-type" pick set-at ] bi ;
-
: set-host-header ( request header -- request header )
over url>> url-host "host" pick set-at ;
over cookies>> [ set-cookie-header ] unless-empty
write-header ;
-PRIVATE>
-
-GENERIC: >post-data ( object -- post-data )
-
-M: f >post-data ;
-
-M: post-data >post-data ;
-
-M: string >post-data
- utf8 encode
- "application/octet-stream" <post-data>
- swap >>data ;
-
-M: assoc >post-data
- "application/x-www-form-urlencoded" <post-data>
- swap >>params ;
-
-M: object >post-data
- "application/octet-stream" <post-data>
- swap >>data ;
-
-<PRIVATE
-
-: normalize-post-data ( request -- request )
- dup post-data>> [
- dup params>> [
- assoc>query ascii encode >>data
- ] when* drop
- ] when* ;
-
-: unparse-post-data ( request -- request )
- [ >post-data ] change-post-data
- normalize-post-data ;
-
-: write-chunk ( chunk -- )
- [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
-
-: write-chunked ( stream -- )
- [ [ write-chunk ] each-block ] with-input-stream
- "0;\r\n" ascii encode write ;
-
-: write-post-data ( request -- request )
- dup method>> { "POST" "PUT" } member? [
- dup post-data>> data>> dup sequence?
- [ write ] [ write-chunked ] if
- ] when ;
-
: write-request ( request -- )
unparse-post-data
write-request-line
dup code>> success? [ download-failed ] unless ;
: with-http-request ( request quot -- response )
- (with-http-request) check-response ; inline
+ [ (with-http-request) check-response ] with-destructors ; inline
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test http.client.post-data ;
+IN: http.client.post-data.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs destructors http io io.encodings.ascii
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.files.info io.pathnames kernel math.parser
+namespaces sequences strings urls.encoding ;
+IN: http.client.post-data
+
+TUPLE: measured-stream stream size ;
+
+C: <measured-stream> measured-stream
+
+<PRIVATE
+
+GENERIC: (set-post-data-headers) ( header data -- header )
+
+M: sequence (set-post-data-headers)
+ length "content-length" pick set-at ;
+
+M: measured-stream (set-post-data-headers)
+ size>> "content-length" pick set-at ;
+
+M: object (set-post-data-headers)
+ drop "chunked" "transfer-encoding" pick set-at ;
+
+PRIVATE>
+
+: set-post-data-headers ( header post-data -- header )
+ [ data>> (set-post-data-headers) ]
+ [ content-type>> "content-type" pick set-at ] bi ;
+
+<PRIVATE
+
+GENERIC: (write-post-data) ( data -- )
+
+M: sequence (write-post-data) write ;
+
+M: measured-stream (write-post-data)
+ stream>> [ [ write ] each-block ] with-input-stream ;
+
+: write-chunk ( chunk -- )
+ [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
+
+M: object (write-post-data)
+ [ [ write-chunk ] each-block ] with-input-stream
+ "0;\r\n" ascii encode write ;
+
+GENERIC: >post-data ( object -- post-data )
+
+M: f >post-data ;
+
+M: post-data >post-data ;
+
+M: string >post-data
+ utf8 encode
+ "application/octet-stream" <post-data>
+ swap >>data ;
+
+M: assoc >post-data
+ "application/x-www-form-urlencoded" <post-data>
+ swap >>params ;
+
+M: object >post-data
+ "application/octet-stream" <post-data>
+ swap >>data ;
+
+: pathname>measured-stream ( pathname -- stream )
+ string>>
+ [ binary <file-reader> &dispose ]
+ [ file-info size>> ] bi
+ <measured-stream> ;
+
+: normalize-post-data ( request -- request )
+ dup post-data>> [
+ dup params>> [
+ assoc>query ascii encode >>data
+ ] when*
+ dup data>> pathname? [
+ [ pathname>measured-stream ] change-data
+ ] when
+ drop
+ ] when* ;
+
+PRIVATE>
+
+: unparse-post-data ( request -- request )
+ [ >post-data ] change-post-data
+ normalize-post-data ;
+
+: write-post-data ( request -- request )
+ dup post-data>> [ data>> (write-post-data) ] when* ;
{ $side-effects "request/response" } ;
HELP: <post-data>
-{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } }
+{ $values { "content-type" "a MIME type string" } { "post-data" post-data } }
{ $description "Creates a new " { $link post-data } "." } ;
HELP: header
LOG: httpd-header NOTICE
-: log-header ( headers name -- )
- tuck header 2array httpd-header ;
+: log-header ( request name -- )
+ [ nip ] [ header ] 2bi 2array httpd-header ;
: log-request ( request -- )
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel macros make multiline namespaces parser
present sequences strings splitting fry accessors ;
IN: interpolate
+<PRIVATE
+
TUPLE: interpolate-var name ;
: (parse-interpolate) ( string -- )
: parse-interpolate ( string -- seq )
[ (parse-interpolate) ] { } make ;
-MACRO: interpolate ( string -- )
- parse-interpolate [
+: (interpolate) ( string quot -- quot' )
+ [ parse-interpolate ] dip '[
dup interpolate-var?
- [ name>> '[ _ get present write ] ]
+ [ name>> @ '[ _ @ present write ] ]
[ '[ _ write ] ]
if
- ] map [ ] join ;
+ ] map [ ] join ; inline
: interpolate-locals ( string -- quot )
- parse-interpolate [
- dup interpolate-var?
- [ name>> search '[ _ present write ] ]
- [ '[ _ write ] ]
- if
- ] map [ ] join ;
+ [ search [ ] ] (interpolate) ;
+
+PRIVATE>
+
+MACRO: interpolate ( string -- )
+ [ [ get ] ] (interpolate) ;
-: I[ "]I" parse-multiline-string
- interpolate-locals parsed \ call parsed ; parsing
+: I[
+ "]I" parse-multiline-string
+ interpolate-locals over push-all ; parsing
\r
: interval-at* ( key map -- value ? )\r
[ drop ] [ array>> find-interval ] 2bi\r
- tuck interval-contains? [ third t ] [ drop f f ] if ;\r
+ [ nip ] [ interval-contains? ] 2bi\r
+ [ third t ] [ drop f f ] if ;\r
\r
: interval-at ( key map -- value ) interval-at* drop ;\r
\r
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
- "WIN32_FIND_DATA" <c-object> tuck
- FindFirstFile
+ "WIN32_FIND_DATA" <c-object>
+ [ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
- "WIN32_FIND_DATA" <c-object> tuck
- FindNextFile 0 = [
+ "WIN32_FIND_DATA" <c-object>
+ [ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
- [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
+ [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
+ [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
- "statfs" <c-object> tuck statfs io-error ;
+ "statfs" <c-object> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
- "statvfs" <c-object> tuck statvfs io-error ;
+ "statvfs" <c-object> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
- "statfs64" <c-object> tuck statfs64 io-error ;
+ "statfs64" <c-object> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
- "statvfs64" <c-object> tuck statvfs64 io-error ;
+ "statvfs64" <c-object> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
- "statfs64" <c-object> tuck statfs64 io-error ;
+ "statfs64" <c-object> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> tuck statvfs io-error ;
+ "statvfs" <c-object> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
- "statvfs" <c-object> tuck statvfs io-error ;
+ "statvfs" <c-object> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
- "statfs" <c-object> tuck statfs io-error ;
+ "statfs" <c-object> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> tuck statvfs io-error ;
+ "statvfs" <c-object> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
output-port <buffered-port> ;
: wait-to-write ( len port -- )
- tuck buffer>> buffer-capacity <=
+ [ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
- "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
+ "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
[ 10 ] [
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Discovered by littledan
+[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
+[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
\ No newline at end of file
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators effects.parser
-generic.parser kernel lexer locals.errors
+generic.parser kernel lexer locals.errors fry
locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words vocabs.parser ;
IN: locals.parser
(parse-bindings)
] [ 2drop ] if ;
+: with-bindings ( quot -- words assoc )
+ '[
+ in-lambda? on
+ _ H{ } make-assoc
+ ] { } make swap ; inline
+
: parse-bindings ( end -- bindings vars )
- [
- [ (parse-bindings) ] H{ } make-assoc
- ] { } make swap ;
+ [ (parse-bindings) ] with-bindings ;
: parse-bindings* ( end -- words assoc )
[
- [
- namespace push-locals
- (parse-bindings)
- namespace pop-locals
- ] { } make-assoc
- ] { } make swap ;
+ namespace push-locals
+ (parse-bindings)
+ namespace pop-locals
+ ] with-bindings ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
] [ 2drop ] if ;
: parse-wbindings ( end -- bindings vars )
- [
- [ (parse-wbindings) ] H{ } make-assoc
- ] { } make swap ;
+ [ (parse-wbindings) ] with-bindings ;
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
: parse-locals-definition ( word -- word quot )
parse-locals \ ; (parse-lambda) <lambda>
- 2dup "lambda" set-word-prop
- rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
+ [ "lambda" set-word-prop ]
+ [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
(match-first) drop ;
: (match-all) ( seq pattern-seq -- )
- tuck (match-first) swap
+ [ nip ] [ (match-first) swap ] 2bi
[
, [ swap (match-all) ] [ drop ] if*
] [ 2drop ] if* ;
[ * ] 2keep gcd nip /i ; foldable
: mod-inv ( x n -- y )
- tuck gcd 1 = [
- dup 0 < [ + ] [ nip ] if
- ] [
- "Non-trivial divisor found" throw
- ] if ; foldable
+ [ nip ] [ gcd 1 = ] 2bi
+ [ dup 0 < [ + ] [ nip ] if ]
+ [ "Non-trivial divisor found" throw ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [
dup V{ 0 } clone p= [
drop nip
] [
- tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
+ [ nip ] [ p/mod ] 2bi
+ [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
PRIVATE>
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
- 2dup gcd nip tuck /i [ /i ] dip fraction>
+ 2dup gcd nip tuck [ /i ] 2bi@ fraction>
] if ;
M: ratio hashcode*
] if ;
: dump-until-separator ( multipart -- multipart )
- dup [ current-separator>> ] [ bytes>> ] bi tuck start [
+ dup
+ [ current-separator>> ] [ bytes>> ] bi
+ [ nip ] [ start ] 2bi [
cut-slice
[ mime-write ]
[ over current-separator>> length tail-slice >>bytes ] bi*
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces make arrays sequences
- peg peg.private accessors words math accessors ;
+ peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
+[ ] [ reset-pegs ] unit-test
+
[
"endbegin" "begin" token parse
] must-fail
"B" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test
-{ f } [ \ + T{ parser f f f } equal? ] unit-test
\ No newline at end of file
+{ f } [ \ + T{ parser f f f } equal? ] unit-test
+
+USE: compiler
+
+[ ] [ disable-compiler ] unit-test
+
+[ ] [ "" epsilon parse drop ] unit-test
+
+[ ] [ enable-compiler ] unit-test
+
+[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
+
+[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test
\ No newline at end of file
IN: persistent.hashtables.nodes.leaf
: matching-key? ( key hashcode leaf-node -- ? )
- tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
+ [ nip ] [ hashcode>> eq? ] 2bi
+ [ key>> = ] [ 2drop f ] if ; inline
M: leaf-node (entry-at) [ matching-key? ] keep and ;
M: object declarations. drop ;
: declaration. ( word prop -- )
- tuck name>> word-prop [ pprint-word ] [ drop ] if ;
+ [ nip ] [ name>> word-prop ] 2bi
+ [ pprint-word ] [ drop ] if ;
M: word declarations.
{
dup
[ nfa-traversal-flags>> ]
[ dfa-table>> transitions>> keys ] bi
- [ tuck [ swap at ] with map concat ] with H{ } map>assoc
+ [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
>>dfa-traversal-flags drop ;
: construct-dfa ( regexp -- )
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
- tuck last-index [ cut-stack-error ] unless* cut-out swap ;
+ [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
-[ { "1" "2" "3" "4" } ]
+[ { "1" "2" "3" "4" "" } ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
+[ { "" } ] [ "" R/ =/ re-split [ >string ] map ] unit-test
+
+[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
+
[ { "ABC" "DEF" "GHI" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
[ 0 ]
[ "123" R/ [A-Z]+/ count-matches ] unit-test
-[ "1.2.3.4" ]
+[ "1.2.3.4." ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
+
+[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
/*
! FIXME
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
-! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
*/
! Bug in parsing word
-[ t ] [ "a" R' a' matches? ] unit-test
+[ t ] [ "a" R' a' matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
dupd first-match
[ split1-slice swap ] [ "" like f swap ] if* ;
+: (re-split) ( string regexp -- )
+ over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ;
+
: re-split ( string regexp -- seq )
- [ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ;
+ [ (re-split) ] { } make ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
- 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
+ 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
: set-transition ( transition hash -- )
#! set the state as a key
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
drop
- "Unknown word: " -rot
- 2array unparse append throw
+ 2array unparse "Unknown word: " prepend throw
] if ;
: deserialize-gensym ( -- word )
\ dll-valid? { object } { object } define-primitive
-\ modify-code-heap { array object } { } define-primitive
+\ modify-code-heap { array } { } define-primitive
\ unimplemented { } { } define-primitive
IN: syndication
: any-tag-named ( tag names -- tag-inside )
- f -rot [ tag-named nip dup ] with find 2drop ;
+ [ f ] 2dip [ tag-named nip dup ] with find 2drop ;
TUPLE: feed title url entries ;
dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- )
- tuck caret>> set-model mark>> set-model ;
+ tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
: select-elt ( editor elt -- )
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- )
- 2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
+ 2dup dim>> =
+ [ 2drop ]
+ [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
GENERIC: pref-dim* ( gadget -- dim )
f >>parent drop ;
: unfocus-gadget ( child gadget -- )
- tuck focus>> eq? [ f >>focus ] when drop ;
+ [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
SYMBOL: in-layout?
dup unparent
over >>parent
tuck ((add-gadget))
- tuck graft-state>> second
- [ graft ]
- [ drop ]
- if ;
+ tuck graft-state>> second [ graft ] [ drop ] if ;
: add-gadget ( parent child -- parent )
not-in-layout
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
[ rect-extent ] dip (screen-rect)
- [ tuck v+ ] dip vmin [ v+ ] dip
+ [ [ nip ] [ v+ ] 2bi ] dip [ v+ ] [ vmin ] 2bi*
] [
rect-extent
] if* ;
] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- )
- tuck next-cursor >>cursor drop ;
+ [ nip ] [ next-cursor ] 2bi >>cursor drop ;
: incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v*
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
- [ grapheme-class tuck grapheme-break? ] find drop
+ [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
<PRIVATE
-! Copyright (C) 2009 Your name.
+! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: unicode.categories
HELP: LETTER
-{ $class-description "The class of upper cased letters" } ;
+{ $class-description "The class of upper cased letters." } ;
HELP: Letter
-{ $class-description "The class of letters" } ;
+{ $class-description "The class of letters." } ;
HELP: alpha
-{ $class-description "The class of code points which are alphanumeric" } ;
+{ $class-description "The class of alphanumeric characters." } ;
HELP: blank
-{ $class-description "The class of code points which are whitespace" } ;
+{ $class-description "The class of whitespace characters." } ;
HELP: character
-{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
+{ $class-description "The class of pre-defined Unicode code points." } ;
HELP: control
-{ $class-description "The class of control characters" } ;
+{ $class-description "The class of control characters." } ;
HELP: digit
-{ $class-description "The class of code coints which are digits" } ;
+{ $class-description "The class of digits." } ;
HELP: letter
-{ $class-description "The class of code points which are lower-cased letters" } ;
+{ $class-description "The class of lower-cased letters." } ;
HELP: printable
-{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
+{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters." } ;
HELP: uncased
-{ $class-description "The class of letters which don't have a case" } ;
+{ $class-description "The class of letters which don't have a case." } ;
ARTICLE: "unicode.categories" "Character classes"
-{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
+"The " { $vocab-link "unicode.categories" } " vocabulary implements predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Each character class has an associated predicate word."
{ $subsection blank }
+{ $subsection blank? }
{ $subsection letter }
+{ $subsection letter? }
{ $subsection LETTER }
+{ $subsection LETTER? }
{ $subsection Letter }
+{ $subsection Letter? }
{ $subsection digit }
+{ $subsection digit? }
{ $subsection printable }
+{ $subsection printable? }
{ $subsection alpha }
+{ $subsection alpha? }
{ $subsection control }
+{ $subsection control? }
{ $subsection uncased }
-{ $subsection character } ;
+{ $subsection uncased? }
+{ $subsection character }
+{ $subsection character? } ;
ABOUT: "unicode.categories"
\r
: filter-ignorable ( weights -- weights' )\r
f swap [\r
- tuck primary>> zero? and\r
+ [ nip ] [ primary>> zero? and ] 2bi\r
[ swap ignorable?>> or ]\r
[ swap completely-ignorable? or not ] 2bi\r
] filter nip ;\r
ABOUT: "unicode.normalize"
ARTICLE: "unicode.normalize" "Unicode normalization"
-"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings. In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: \"e\\u000301\" (the e character, followed by the combining acute accent character) and \"\\u0000e9\" (a single character, e with an acute accent). There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care. Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
+"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings."
+$nl
+"In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: " { $snippet "\"e\\u000301\"" } " (the e character, followed by the combining acute accent character) and " { $snippet "\"\\u0000e9\"" } " (a single character, e with an acute accent)."
+$nl
+"There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care."
+$nl
+"Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
{ $subsection nfc }
{ $subsection nfd }
{ $subsection nfkc }
HELP: nfc
{ $values { "string" string } { "nfc" "a string in NFC" } }
-{ $description "Converts a string to Normalization Form C" } ;
+{ $description "Converts a string to Normalization Form C." } ;
HELP: nfd
{ $values { "string" string } { "nfd" "a string in NFD" } }
-{ $description "Converts a string to Normalization Form D" } ;
+{ $description "Converts a string to Normalization Form D." } ;
HELP: nfkc
{ $values { "string" string } { "nfkc" "a string in NFKC" } }
-{ $description "Converts a string to Normalization Form KC" } ;
+{ $description "Converts a string to Normalization Form KC." } ;
HELP: nfkd
{ $values { "string" string } { "nfkd" "a string in NFKD" } }
-{ $description "Converts a string to Normalization Form KD" } ;
+{ $description "Converts a string to Normalization Form KD." } ;
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax strings ;
IN: unicode
ARTICLE: "unicode" "Unicode"
-"Unicode is a set of characters, or " { $emphasis "code points" } " covering what's used in most world writing systems. Any Factor string can hold any of these code points transparently; a factor string is a sequence of Unicode code points. Unicode is accompanied by several standard algorithms for common operations like encoding in files, capitalizing a string, finding the boundaries between words, etc. When a programmer is faced with a string manipulation problem, where the string represents human language, a Unicode algorithm is often much better than the naive one. This is not in terms of efficiency, but rather internationalization. Even English text that remains in ASCII is better served by the Unicode collation algorithm than a naive algorithm. The Unicode algorithms implemented here are:"
+"The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set."
+$nl
+"The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points."
+$nl
+"The Unicode character set is accompanied by several standard algorithms for common operations like encoding text in files, capitalizing a string, finding the boundaries between words, and so on."
+$nl
+"The Unicode algorithms implemented by the " { $vocab-link "unicode" } " vocabulary are:"
{ $vocab-subsection "Case mapping" "unicode.case" }
{ $vocab-subsection "Collation and weak comparison" "unicode.collation" }
{ $vocab-subsection "Character classes" "unicode.categories" }
"The following are mostly for internal use:"
{ $vocab-subsection "Unicode syntax" "unicode.syntax" }
{ $vocab-subsection "Unicode data tables" "unicode.data" }
-{ $see-also "io.encodings" } ;
+{ $see-also "ascii" "io.encodings" } ;
ABOUT: "unicode"
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
-io.backend.unix io.encodings.utf8 unix.utilities ;
+io.backend.unix io.encodings.utf8 unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
[ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
- [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
+ [ [ fork-process dup zero? ] dip '[ drop @ ] ] dip
if ; inline
CONSTANT: SIGKILL 9
: change-file-times ( filename access modification -- )
"utimebuf" <c-object>
- tuck set-utimbuf-modtime
- tuck set-utimbuf-actime
+ [ set-utimbuf-modtime ] keep
+ [ set-utimbuf-actime ] keep
[ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;
] if ;
: own-selection ( prop win -- )
- dpy get -rot CurrentTime XSetSelectionOwner drop
+ [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )
: set-size-hints ( window -- )
"XSizeHints" <c-object>
USPosition over set-XSizeHints-flags
- dpy get -rot XSetWMNormalHints ;
+ [ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
{ 0 0 } = [ drop ] [ set-size-hints ] if ;
M: attrs clear-assoc
f >>alist drop ;
M: attrs delete-at
- tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
+ [ nip ] [ attr@ drop ] 2bi
+ [ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
alist>> clone <attrs> ;
[ ch>upper ] dip rules>> at ?push-all ;
: get-rules ( char ruleset -- seq )
- f -rot [ get-char-rules ] keep get-always-rules ;
+ [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
GENERIC: handle-rule-start ( match-count rule -- )
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
- f -rot
+ [ f ] 2dip
'[ nip @ dup ] find
[ [ drop f ] unless ] dip ; inline
M: sequence clear-assoc delete-all ;
M: sequence delete-at
- tuck search-alist nip
+ [ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ;
M: sequence assoc-size length ;
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab vocab-words bootstrap-syntax set
-H{ } clone dictionary set
-H{ } clone new-classes set
-H{ } clone changed-definitions set
-H{ } clone changed-generics set
-H{ } clone remake-generics set
-H{ } clone forgotten-definitions set
-H{ } clone root-cache set
-H{ } clone source-files set
-H{ } clone update-map set
-H{ } clone implementors-map set
+"syntax" vocab vocab-words bootstrap-syntax set {
+ dictionary
+ new-classes
+ changed-definitions changed-generics
+ remake-generics forgotten-definitions
+ root-cache source-files update-map implementors-map
+} [ H{ } clone swap set ] each
+
init-caches
! Vocabulary for slot accessors
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
- { "compiled" read-only }
+ { "optimized" read-only }
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
! using the host image's hashing algorithms. We don't
! use each-object here since the catch stack isn't yet
! set up.
+ gc
begin-scan
[ hashtable? ] pusher [ (each-object) ] dip
end-scan
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
[ drop f ] [\r
- tuck [ class<= ] with all? [ peek ] [ drop f ] if\r
+ [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
dup "predicate" word-prop
dup length 1 = [
first
- tuck "predicating" word-prop =
+ [ nip ] [ "predicating" word-prop = ] 2bi
[ forget ] [ drop ] if
] [ 2drop ] if ;
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep
- tuck [ new-class? ] either? [
+ [ nip ] [ [ new-class? ] either? ] 2bi [
update-classes/new
] [
update-classes
IN: compiler.units.tests
-USING: definitions compiler.units tools.test arrays sequences ;
+USING: definitions compiler.units tools.test arrays sequences words kernel
+accessors namespaces fry ;
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
+
+! Non-optimizing compiler bugs
+[ 1 1 ] [
+ "A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap
+ 1 swap execute
+] unit-test
+
+[ "A" "B" ] [
+ gensym "a" set
+ gensym "b" set
+ [
+ "a" get [ "A" ] define
+ "b" get "a" get '[ _ execute ] define
+ ] with-compilation-unit
+ "b" get execute
+ [
+ "a" get [ "B" ] define
+ ] with-compilation-unit
+ "b" get execute
+] unit-test
\ No newline at end of file
dup dup changed-vocabs update ;
: compile ( words -- )
- recompile-hook get call
- dup [ drop crossref? ] assoc-contains?
- modify-code-heap ;
+ recompile-hook get call modify-code-heap ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
call-recompile-hook
call-update-tuples-hook
unxref-forgotten-definitions
- dup [ drop crossref? ] assoc-contains? modify-code-heap ;
+ modify-code-heap ;
: with-nested-compilation-unit ( quot -- )
[
ERROR: bad-effect ;
: parse-effect-token ( end -- token/f )
- scan tuck = [ drop f ] [
+ scan [ nip ] [ = ] 2bi [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan-word {
"methods" word-prop keys sort-classes ;
: specific-method ( class generic -- method/f )
- tuck order min-class dup [ swap method ] [ 2drop f ] if ;
+ [ nip ] [ order min-class ] 2bi
+ dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )
[ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
M: hashtable delete-at ( key hash -- )
- tuck key@ [
+ [ nip ] [ key@ ] 2bi [
[ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+
] [
IN: memory
HELP: begin-scan ( -- )
-{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
+{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
$nl
"This word must always be paired with a call to " { $link end-scan } "." }
{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
] [ 2drop ] if ; inline recursive
: each-object ( quot -- )
- begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
+ gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
: count-instances ( quot -- n )
0 swap [ 1 0 ? + ] compose each-object ; inline
[
[
lines dup parse-fresh
- tuck finish-parsing
+ [ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
] with-compilation-unit ;
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
: (2sequence) ( obj1 obj2 seq -- seq )
- tuck 1 swap set-nth-unsafe
- tuck 0 swap set-nth-unsafe ; inline
+ [ 1 swap set-nth-unsafe ] keep
+ [ 0 swap set-nth-unsafe ] keep ; inline
: (3sequence) ( obj1 obj2 obj3 seq -- seq )
- tuck 2 swap set-nth-unsafe
+ [ 2 swap set-nth-unsafe ] keep
(2sequence) ; inline
: (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq )
- tuck 3 swap set-nth-unsafe
+ [ 3 swap set-nth-unsafe ] keep
(3sequence) ; inline
PRIVATE>
2dup shorter? [
2drop f
] [
- tuck length head-slice sequence=
+ [ nip ] [ length head-slice ] 2bi sequence=
] if ;
: tail? ( seq end -- ? )
2dup shorter? [
2drop f
] [
- tuck length tail-slice* sequence=
+ [ nip ] [ length tail-slice* ] 2bi sequence=
] if ;
: cut-slice ( seq n -- before-slice after-slice )
{ $subsection 1string }
"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:"
{ $list
- { { $vocab-link "ascii" } " - traditional ASCII character classes" }
- { { $vocab-link "unicode.categories" } " - Unicode character classes" }
- { { $vocab-link "unicode.case" } " - Unicode case conversion" }
+ { { $link "ascii" } " - ASCII algorithms for interoperability with legacy applications" }
+ { { $link "unicode" } " - Unicode algorithms for modern multilingual applications" }
{ { $vocab-link "regexp" } " - regular expressions" }
{ { $vocab-link "peg" } " - parser expression grammars" }
} ;
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit grouping kernel math math.parser namespaces
- sequences ;
+USING: combinators.short-circuit grouping kernel math math.parser
+math.text.utils namespaces sequences ;
IN: math.text.english
<PRIVATE
: negative-text ( n -- str )
0 < "Negative " "" ? ;
-: 3digit-groups ( n -- seq )
- [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
-
: hundreds-place ( n -- str )
100 /mod over 0 = [
2drop ""
--- /dev/null
+Samuel Tardieu
--- /dev/null
+USING: help.markup help.syntax ;
+IN: math.text.french
+
+HELP: number>text
+{ $values { "n" "an integer" } { "str" "a string" } }
+{ $description "Return the a string describing " { $snippet "n" } " in French. Numbers with absolute value equal to or greater than 10^12 will be returned using their numeric representation." } ;
--- /dev/null
+USING: math math.functions math.parser math.text.french sequences tools.test ;
+
+[ "zéro" ] [ 0 number>text ] unit-test
+[ "vingt et un" ] [ 21 number>text ] unit-test
+[ "vingt-deux" ] [ 22 number>text ] unit-test
+[ "deux mille" ] [ 2000 number>text ] unit-test
+[ "soixante et un" ] [ 61 number>text ] unit-test
+[ "soixante-deux" ] [ 62 number>text ] unit-test
+[ "quatre-vingts" ] [ 80 number>text ] unit-test
+[ "quatre-vingt-un" ] [ 81 number>text ] unit-test
+[ "quatre-vingt-onze" ] [ 91 number>text ] unit-test
+[ "deux cents" ] [ 200 number>text ] unit-test
+[ "mille deux cents" ] [ 1200 number>text ] unit-test
+[ "mille deux cent quatre-vingts" ] [ 1280 number>text ] unit-test
+[ "mille deux cent quatre-vingt-un" ] [ 1281 number>text ] unit-test
+[ "un billion deux cent vingt milliards quatre-vingts millions trois cent quatre-vingt mille deux cents" ] [ 1220080380200 number>text ] unit-test
+[ "un million" ] [ 1000000 number>text ] unit-test
+[ "un million un" ] [ 1000001 number>text ] unit-test
+[ "moins vingt" ] [ -20 number>text ] unit-test
+[ 104 ] [ -1 10 102 ^ - number>text length ] unit-test
+! Check that we do not exhaust stack
+[ 1484 ] [ 10 100 ^ 1 - number>text length ] unit-test
--- /dev/null
+! Copyright (c) 2009 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math math.functions
+math.parser math.text.utils memoize sequences ;
+IN: math.text.french
+
+<PRIVATE
+
+DEFER: basic ( n -- str )
+
+CONSTANT: literals
+ H{ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
+ { 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
+ { 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
+ { 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
+ { 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
+ { 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
+ { 71 "soixante et onze" } { 80 "quatre-vingts" }
+ { 81 "quatre-vingt-un" }
+ { 100 "cent" } { 1000 "mille" } }
+
+MEMO: units ( -- seq ) ! up to 10^99
+ { "m" "b" "tr" "quadr" "quint" "sext" "sept" "oct"
+ "non" "déc" "unodéc" "duodéc" "trédéc" "quattuordéc"
+ "quindéc" "sexdéc" }
+ [ [ "illion" append ] [ "illiard" append ] bi 2array ] map concat
+ "mille" prefix ;
+
+! The only plurals we have to remove are "quatre-vingts" and "cents",
+! which are also the only strings ending with "ts".
+: unpluralize ( str -- newstr ) dup "ts" tail? [ but-last ] when ;
+: pluralize ( str -- newstr ) CHAR: s suffix ;
+
+: space-append ( str1 str2 -- str ) " " glue ;
+
+! Small numbers (below 100) use dashes between them unless they are
+! separated with "et". Pluralized prefixes must be unpluralized.
+: complete-small ( str n -- str )
+ { { 0 [ ] }
+ { 1 [ " et un" append ] }
+ [ [ unpluralize ] dip basic "-" glue ] } case ;
+
+: smaller-than-60 ( n -- str )
+ dup 10 mod [ - ] keep [ basic ] dip complete-small ;
+
+: base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete-small ;
+
+: smaller-than-80 ( n -- str ) 60 base-onto ;
+
+: smaller-than-100 ( n -- str ) 80 base-onto ;
+
+: if-zero ( n quot quot -- )
+ [ dup zero? ] 2dip [ [ drop ] prepose ] dip if ; inline
+
+: complete ( str n -- newstr )
+ [ ] [ basic space-append ] if-zero ;
+
+: smaller-than-1000 ( n -- str )
+ 100 /mod
+ [ "cent" swap dup 1 = [ drop ] [ basic swap space-append ] if ]
+ [ [ pluralize ] [ basic space-append ] if-zero ] bi* ;
+
+: smaller-than-2000 ( n -- str ) "mille" swap 1000 - complete ;
+
+: smaller-than-1000000 ( n -- str )
+ 1000 /mod [ basic unpluralize " mille" append ] dip complete ;
+
+: n-units ( n unit -- str/f )
+ {
+ { [ over zero? ] [ 2drop f ] }
+ { [ over 1 = ] [ [ basic ] dip space-append ] }
+ [ [ basic ] dip space-append pluralize ]
+ } cond ;
+
+: over-1000000 ( n -- str )
+ 3digit-groups [ 1+ units nth n-units ] map-index sift
+ reverse " " join ;
+
+: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
+
+: basic ( n -- str )
+ {
+ { [ dup literals key? ] [ literals at ] }
+ { [ dup 0 < ] [ abs basic "moins " swap append ] }
+ { [ dup 60 < ] [ smaller-than-60 ] }
+ { [ dup 80 < ] [ smaller-than-80 ] }
+ { [ dup 100 < ] [ smaller-than-100 ] }
+ { [ dup 1000 < ] [ smaller-than-1000 ] }
+ { [ dup 2000 < ] [ smaller-than-2000 ] }
+ { [ dup 1000000 < ] [ smaller-than-1000000 ] }
+ [ decompose ]
+ } cond ;
+
+PRIVATE>
+
+: number>text ( n -- str )
+ dup abs 10 102 ^ >= [ number>string ] [ basic ] if ;
--- /dev/null
+Convert integers to French text
--- /dev/null
+Aaron Schaefer
--- /dev/null
+Number to text conversion utilities
--- /dev/null
+USING: help.markup help.syntax ;
+IN: math.text.utils
+
+HELP: 3digit-groups
+{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
+{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;
--- /dev/null
+USING: math.text.utils tools.test ;
+
+[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test
--- /dev/null
+! Copyright (c) 2007, 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: math.text.utils
+
+: 3digit-groups ( n -- seq )
+ [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
+++ /dev/null
-
-USING: io io.encodings.ascii io.files io.files.temp io.launcher
- locals math.parser sequences sequences.deep
- help.syntax
- easy-help ;
-
-IN: size-of
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-Word: size-of
-
-Values:
-
- HEADERS sequence : List of header files
- TYPE string : A C type
- n integer : Size in number of bytes ..
-
-Description:
-
- Use 'size-of' to find out the size in bytes of a C type.
-
- The 'headers' argument is a list of header files to use. You may
- pass 'f' to only use 'stdio.h'. ..
-
-Example:
-
- ! Find the size of 'int'
-
- f "int" size-of . ..
-
-Example:
-
- ! Find the size of the 'XAnyEvent' struct from Xlib.h
-
- { "X11/Xlib.h" } "XAnyEvent" size-of . ..
-
-;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: size-of ( HEADERS TYPE -- n )
-
- [let | C-FILE [ "size-of.c" temp-file ]
- EXE-FILE [ "size-of" temp-file ]
- INCLUDES [ HEADERS [| FILE | { "#include <" FILE ">" } concat ] map ] |
-
- {
- "#include <stdio.h>"
- INCLUDES
- "main() { printf( \"%i\" , sizeof( " TYPE " ) ) ; }"
- }
-
- flatten C-FILE ascii set-file-lines
-
- { "gcc" C-FILE "-o" EXE-FILE } try-process
-
- EXE-FILE ascii <process-reader> contents string>number ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-FUEL, Factor's Ultimate Emacs Library -*- org -*-
+FUEL, Factor's Ultimate Emacs Library
-------------------------------------
FUEL provides a complete environment for your Factor coding pleasure
* Basic usage
*** Running the listener
- If you're using the default factor binary and images locations inside
- the Factor's source tree, that should be enough to start using FUEL.
- Editing any file with the extension .factor will put you in
- factor-mode; try C-hm for a summary of available commands.
+ If you're using the default factor binary and images locations inside
+ the Factor's source tree, that should be enough to start using FUEL.
+ Editing any file with the extension .factor will put you in
+ factor-mode; try C-hm for a summary of available commands.
- To start the listener, try M-x run-factor.
+ To start the listener, try M-x run-factor.
- By default, FUEL will try to use the binary and image files in the
- factor installation directory. You can customize them with:
+ By default, FUEL will try to use the binary and image files in the
+ factor installation directory. You can customize them with:
(setq fuel-listener-factor-binary <full path to factor>)
(setq fuel-listener-factor-image <full path to factor image>)
- Many aspects of the environment can be customized:
- M-x customize-group fuel will show you how many.
+ Many aspects of the environment can be customized:
+ M-x customize-group fuel will show you how many.
*** Faster listener startup
- On startup, run-factor loads the fuel vocabulary, which can take a
- while. If you want to speedup the load process, type 'save' in the
- listener prompt just after invoking run-factor. This will save a
- factor image (overwriting the current one) with all the needed
- vocabs.
+ On startup, run-factor loads the fuel vocabulary, which can take a
+ while. If you want to speedup the load process, type 'save' in the
+ listener prompt just after invoking run-factor. This will save a
+ factor image (overwriting the current one) with all the needed
+ vocabs.
*** Connecting to a running Factor
- 'run-factor' starts a new factor listener process managed by Emacs.
- If you prefer to start Factor externally, you can also connect
- remotely from Emacs. Here's how to proceed:
+ 'run-factor' starts a new factor listener process managed by Emacs.
+ If you prefer to start Factor externally, you can also connect
+ remotely from Emacs. Here's how to proceed:
- - In the factor listener, run FUEL:
- "fuel" run
- This will start a server listener in port 9000.
- - Switch to Emacs and issue the command 'M-x connect-to-factor'.
+ - In the factor listener, run FUEL: "fuel" run
+ This will start a server listener in port 9000.
+ - Switch to Emacs and issue the command 'M-x connect-to-factor'.
That's it; you should be up and running. See the help for
'connect-to-factor' for how to use a different port.
*** Vocabulary creation
- FUEL offers a basic interface with Factor's scaffolding utilities.
+ FUEL offers a basic interface to Factor's scaffolding utilities.
To create a new vocabulary directory and associated files:
M-x fuel-scaffold-vocab
* Quick key reference
- (Triple chords ending in a single letter <x> accept also C-<x> (e.g.
- C-cC-eC-r is the same as C-cC-er)).
+ Triple chords ending in a single letter <x> accept also C-<x> (e.g.
+ C-cC-eC-r is the same as C-cC-er).
*** In factor source files:
- - C-cz : switch to listener
- - C-co : cycle between code, tests and docs factor files
- - C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
- - C-cr : switch to listener and refresh all loaded vocabs
- - C-x4s : switch to other factor buffer in other window
- - C-x5s : switch to other factor buffer in other frame
-
- - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
- - M-, : go back to where M-. was last invoked
- - M-TAB : complete word at point
- - C-cC-eu : update USING: line
- - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
- - C-cC-ew : edit word (M-x fuel-edit-word-at-point)
- - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point)
-
- - C-cC-er : eval region
- - C-M-r, C-cC-ee : eval region, extending it to definition boundaries
- - C-M-x, C-cC-ex : eval definition around point
- - C-ck, C-cC-ek : run file
-
- - C-cC-da : toggle autodoc mode
- - C-cC-dd : help for word at point
- - C-cC-ds : short help word at point
- - C-cC-de : show stack effect of current sexp (with prefix, region)
- - C-cC-dp : find words containing given substring (M-x fuel-apropos)
- - C-cC-dv : show words in current file (with prefix, ask for vocab)
-
- - C-cM-<, C-cC-d< : show callers of word or vocabulary at point
- (M-x fuel-show-callers, M-x fuel-vocab-usage)
- - C-cM->, C-cC-d> : show callees of word or vocabulary at point
- (M-x fuel-show-callees, M-x fuel-vocab-uses)
-
- - C-cC-xs : extract innermost sexp (up to point) as a separate word
- - C-cC-xr : extract region as a separate word
- - C-cC-xi : replace word at point by its definition
- - C-cC-xv : extract region as a separate vocabulary
- - C-cC-xw : rename all uses of a word
+ Commands in parenthesis can be invoked interactively with
+ M-x <command>, not necessarily in a factor buffer.
+
+ |-----------------+------------------------------------------------------------|
+ | C-cz | switch to listener (run-factor) |
+ | C-co | cycle between code, tests and docs files |
+ | C-cr | switch to listener and refresh all loaded vocabs |
+ | C-cs | switch to other factor buffer (fuel-switch-to-buffer) |
+ | C-x4s | switch to other factor buffer in other window |
+ | C-x5s | switch to other factor buffer in other frame |
+ |-----------------+------------------------------------------------------------|
+ | M-. | edit word at point in Emacs (fuel-edit-word) |
+ | M-, | go back to where M-. was last invoked |
+ | M-TAB | complete word at point |
+ | C-cC-eu | update USING: line (fuel-update-usings) |
+ | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) |
+ | C-cC-ew | edit word (fuel-edit-word-at-point) |
+ | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) |
+ |-----------------+------------------------------------------------------------|
+ | C-cC-er | eval region |
+ | C-M-r, C-cC-ee | eval region, extending it to definition boundaries |
+ | C-M-x, C-cC-ex | eval definition around point |
+ | C-ck, C-cC-ek | run file (fuel-run-file) |
+ |-----------------+------------------------------------------------------------|
+ | C-cC-da | toggle autodoc mode (fuel-autodoc-mode) |
+ | C-cC-dd | help for word at point (fuel-help) |
+ | C-cC-ds | short help word at point (fuel-help-short) |
+ | C-cC-de | show stack effect of current sexp (with prefix, region) |
+ | C-cC-dp | find words containing given substring (fuel-apropos) |
+ | C-cC-dv | show words in current file (with prefix, ask for vocab) |
+ |-----------------+------------------------------------------------------------|
+ | C-cM-<, C-cC-d< | show callers of word or vocabulary at point |
+ | | (fuel-show-callers, fuel-vocab-usage) |
+ | C-cM->, C-cC-d> | show callees of word or vocabulary at point |
+ | | (fuel-show-callees, fuel-vocab-uses) |
+ |-----------------+------------------------------------------------------------|
+ | C-cC-xs | extract innermost sexp (up to point) as a separate word |
+ | | (fuel-refactor-extract-sexp) |
+ | C-cC-xr | extract region as a separate word |
+ | | (fuel-refactor-extract-region) |
+ | C-cC-xv | extract region as a separate vocabulary |
+ | | (fuel-refactor-extract-vocab) |
+ | C-cC-xi | replace word by its definition (fuel-refactor-inline-word) |
+ | C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) |
+ |-----------------+------------------------------------------------------------|
*** In the listener:
- - TAB : complete word at point
- - M-. : edit word at point in Emacs
- - C-cr : refresh all loaded vocabs
- - C-ca : toggle autodoc mode
- - C-cp : find words containing given substring (M-x fuel-apropos)
- - C-cs : toggle stack mode
- - C-cv : edit vocabulary
- - C-ch : help for word at point
- - C-ck : run file
+ |------+----------------------------------------------------------|
+ | TAB | complete word at point |
+ | M-. | edit word at point in Emacs |
+ | C-cr | refresh all loaded vocabs |
+ | C-ca | toggle autodoc mode |
+ | C-cp | find words containing given substring (M-x fuel-apropos) |
+ | C-cs | toggle stack mode |
+ | C-cv | edit vocabulary |
+ | C-ch | help for word at point |
+ | C-ck | run file |
+ |------+----------------------------------------------------------|
*** In the debugger (it pops up upon eval/compilation errors):
- - g : go to error
- - <digit> : invoke nth restart
- - w/e/l : invoke :warnings, :errors, :linkage
- - q : bury buffer
+ |---------+-------------------------------------|
+ | g | go to error |
+ | <digit> | invoke nth restart |
+ | w/e/l | invoke :warnings, :errors, :linkage |
+ | q | bury buffer |
+ |---------+-------------------------------------|
*** In the help browser:
- - h : help for word at point
- - v : help for a vocabulary
- - a : find words containing given substring (M-x fuel-apropos)
- - e : edit current article
- - ba : bookmark current page
- - bb : display bookmarks
- - bd : delete bookmark at point
- - n/p : next/previous page
- - l : previous page
- - SPC/S-SPC : scroll up/down
- - TAB/S-TAB : next/previous link
- - k : kill current page and go to previous or next
- - r : refresh page
- - c : clean browsing history
- - M-. : edit word at point in Emacs
- - C-cz : switch to listener
- - q : bury buffer
+ |-----------+----------------------------------------------------------|
+ | h | help for word at point |
+ | v | help for a vocabulary |
+ | a | find words containing given substring (M-x fuel-apropos) |
+ | e | edit current article |
+ | ba | bookmark current page |
+ | bb | display bookmarks |
+ | bd | delete bookmark at point |
+ | n/p | next/previous page |
+ | l | previous page |
+ | SPC/S-SPC | scroll up/down |
+ | TAB/S-TAB | next/previous link |
+ | k | kill current page and go to previous or next |
+ | r | refresh page |
+ | c | clean browsing history |
+ | M-. | edit word at point in Emacs |
+ | C-cz | switch to listener |
+ | q | bury buffer |
+ |-----------+----------------------------------------------------------|
*** In crossref buffers
- - TAB/BACKTAB : navigate links
- - RET/mouse click : follow link
- - h : show help for word at point
- - q : bury buffer
+ |-----------------+-----------------------------|
+ | TAB/BACKTAB | navigate links |
+ | RET/mouse click | follow link |
+ | h | show help for word at point |
+ | q | bury buffer |
+ |-----------------+-----------------------------|
(case (car sexp)
(:array (factor--seq 'V{ '} (cdr sexp)))
(:seq (factor--seq '{ '} (cdr sexp)))
+ (:tuple (factor--seq 'T{ '} (cdr sexp)))
(:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
(:quotation (factor--seq '\[ '\] (cdr sexp)))
(:using (factor `(USING: ,@(cdr sexp) :end)))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
+ (cond ((looking-at "USING: ")
+ 'factor-font-lock-vocabulary-name)
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
'factor-font-lock-symbol)
+ ((looking-at "C-ENUM:\\( \\|\n\\)")
+ 'factor-font-lock-constant)
(t 'default))))
- ((char-equal c ?U) 'factor-font-lock-parsing-word)
+ ((or (char-equal c ?U) (char-equal c ?C))
+ 'factor-font-lock-parsing-word)
((char-equal c ?\() 'factor-font-lock-stack-effect)
((char-equal c ?\") 'factor-font-lock-string)
(t 'factor-font-lock-comment)))))
(defconst fuel-font-lock--font-lock-keywords
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
+ (,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-type-name)
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)
- ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
+ ("\\_<\\(P\\|SBUF\\|DLL\\)\"" 1 'factor-font-lock-parsing-word)
(,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
(defvar fuel-markup--maybe-nl nil))
(defun fuel-markup--print (e)
- (cond ((null e))
+ (cond ((null e) (insert "f"))
((stringp e) (fuel-markup--insert-string e))
((and (listp e) (symbolp (car e))
(assoc (car e) fuel-markup--printers))
(insert (cadr e))))
(defun fuel-markup--snippet (e)
- (let ((snip (format "%s" (cadr e))))
- (insert (fuel-font-lock--factor-str snip))))
+ (insert (mapconcat '(lambda (s)
+ (if (stringp s)
+ (fuel-font-lock--factor-str s)
+ (fuel-markup--print-str s)))
+ (cdr e)
+ " ")))
(defun fuel-markup--code (e)
(fuel-markup--insert-nl-if-nb)
(fuel-markup--snippet (cons '$snippet (cdr e))))
(defun fuel-markup--link (e)
- (let* ((link (nth 1 e))
+ (let* ((link (or (nth 1 e) 'f))
(type (or (nth 3 e) (if (symbolp link) 'word 'article)))
(label (or (nth 2 e)
(and (eq type 'article)
;;; Regexps galore:
(defconst fuel-syntax--parsing-words
- '(":" "::" ";" "<<" "<PRIVATE" ">>"
- "ABOUT:" "ALIAS:" "ARTICLE:"
+ '(":" "::" ";" "
&:" "<<" "<PRIVATE" ">>"
+ "ABOUT:" "ALIAS:" "ALIEN:" "ARTICLE:"
"B" "BIN:"
- "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
+ "C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
"ERROR:" "EXCLUDE:"
- "f" "FORGET:" "FROM:"
+ "f" "FORGET:" "FROM:" "FUNCTION:"
"GENERIC#" "GENERIC:"
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
+ "LIBRARY:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:"
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
'("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))
(defconst fuel-syntax--int-constant-def-regex
- (fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:")))
+ (fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "OCT:")))
(defconst fuel-syntax--type-definition-regex
- (fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
+ (fuel-syntax--second-word-regex
+ '("C-STRUCT:" "C-UNION:" "MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
(defconst fuel-syntax--tuple-decl-regex
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
(defconst fuel-syntax--setter-regex "\\_<>>.+?\\_>")
(defconst fuel-syntax--symbol-definition-regex
- (fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
+ (fuel-syntax--second-word-regex '("&:" "SYMBOL:" "VAR:")))
(defconst fuel-syntax--stack-effect-regex
"\\( ( .* )\\)\\|\\( (( .* ))\\)")
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
+(defconst fuel-syntax--alien-function-regex
+ "\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")
+
(defconst fuel-syntax--indent-def-starts '("" ":"
- "FROM"
+ "C-ENUM" "C-STRUCT" "C-UNION"
+ "FROM" "FUNCTION:"
"INTERSECTION:"
"M" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
- (format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
+ (format "^\\(%s:\\)\\( \\|\n\\)" (regexp-opt fuel-syntax--indent-def-starts)))
(defconst fuel-syntax--no-indent-def-start-regex
(format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
"GENERIC:" "GENERIC#"
"HELP:" "HEX:" "HOOK:"
"IN:" "INSTANCE:"
+ "LIBRARY:"
"MAIN:" "MATH:" "MIXIN:"
"OCT:"
"POSTPONE:" "PRIVATE>" "<PRIVATE"
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings
+ ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)"
+ (3 "\"") (4 "\""))
("\\( \\|^\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)" (2 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))
+ ("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
+ ("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)"
(2 "<b"))
--- /dev/null
+
+USING: io io.encodings.ascii io.files io.files.temp io.launcher
+ locals math.parser sequences sequences.deep
+ help.syntax
+ easy-help ;
+
+IN: size-of
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+Word: size-of
+
+Values:
+
+ HEADERS sequence : List of header files
+ TYPE string : A C type
+ n integer : Size in number of bytes ..
+
+Description:
+
+ Use 'size-of' to find out the size in bytes of a C type.
+
+ The 'headers' argument is a list of header files to use. You may
+ pass 'f' to only use 'stdio.h'. ..
+
+Example:
+
+ ! Find the size of 'int'
+
+ f "int" size-of . ..
+
+Example:
+
+ ! Find the size of the 'XAnyEvent' struct from Xlib.h
+
+ { "X11/Xlib.h" } "XAnyEvent" size-of . ..
+
+;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: size-of ( HEADERS TYPE -- n )
+
+ [let | C-FILE [ "size-of.c" temp-file ]
+ EXE-FILE [ "size-of" temp-file ]
+ INCLUDES [ HEADERS [| FILE | { "#include <" FILE ">" } concat ] map ] |
+
+ {
+ "#include <stdio.h>"
+ INCLUDES
+ "main() { printf( \"%i\" , sizeof( " TYPE " ) ) ; }"
+ }
+
+ flatten C-FILE ascii set-file-lines
+
+ { "gcc" C-FILE "-o" EXE-FILE } try-process
+
+ EXE-FILE ascii <process-reader> contents string>number ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
critical_error("Bug in set_callstack()",0);
}
-F_COMPILED *frame_code(F_STACK_FRAME *frame)
+F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
{
- return (F_COMPILED *)frame->xt - 1;
+ return (F_CODE_BLOCK *)frame->xt - 1;
}
CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame)
{
- F_COMPILED *compiled = frame_code(frame);
- CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start + compiled->code_length;
-
- return get(literal_start);
+ F_CODE_BLOCK *compiled = frame_code(frame);
+ if(compiled->literals == F)
+ return F;
+ else
+ {
+ F_ARRAY *array = untag_object(compiled->literals);
+ return array_nth(array,0);
+ }
}
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
-F_COMPILED *frame_code(F_STACK_FRAME *frame);
+F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
--- /dev/null
+#include "master.h"
+
+void flush_icache_for(F_CODE_BLOCK *compiled)
+{
+ CELL start = (CELL)(compiled + 1);
+ flush_icache(start,compiled->code_length);
+}
+
+void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
+{
+ if(compiled->relocation != F)
+ {
+ F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
+
+ F_REL *rel = (F_REL *)(relocation + 1);
+ F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
+
+ while(rel < rel_end)
+ {
+ iter(rel,compiled);
+ rel++;
+ }
+ }
+}
+
+/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
+INLINE void store_address_2_2(CELL cell, CELL value)
+{
+ put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
+ put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
+}
+
+/* Store a value into a bitfield of a PowerPC instruction */
+INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
+{
+ /* This is unaccurate but good enough */
+ F_FIXNUM test = (F_FIXNUM)mask >> 1;
+ if(value <= -test || value >= test)
+ critical_error("Value does not fit inside relocation",0);
+
+ u32 original = *(u32*)cell;
+ original &= ~mask;
+ *(u32*)cell = (original | ((value >> shift) & mask));
+}
+
+/* Perform a fixup on a code block */
+void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
+{
+ F_FIXNUM relative_value = absolute_value - offset;
+
+ switch(class)
+ {
+ case RC_ABSOLUTE_CELL:
+ put(offset,absolute_value);
+ break;
+ case RC_ABSOLUTE:
+ *(u32*)offset = absolute_value;
+ break;
+ case RC_RELATIVE:
+ *(u32*)offset = relative_value - sizeof(u32);
+ break;
+ case RC_ABSOLUTE_PPC_2_2:
+ store_address_2_2(offset,absolute_value);
+ break;
+ case RC_RELATIVE_PPC_2:
+ store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+ break;
+ case RC_RELATIVE_PPC_3:
+ store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+ break;
+ case RC_RELATIVE_ARM_3:
+ store_address_masked(offset,relative_value - CELLS * 2,
+ REL_RELATIVE_ARM_3_MASK,2);
+ break;
+ case RC_INDIRECT_ARM:
+ store_address_masked(offset,relative_value - CELLS,
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ case RC_INDIRECT_ARM_PC:
+ store_address_masked(offset,relative_value - CELLS * 2,
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ default:
+ critical_error("Bad rel class",class);
+ break;
+ }
+}
+
+void update_literal_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
+{
+ if(REL_TYPE(rel) == RT_IMMEDIATE)
+ {
+ CELL offset = rel->offset + (CELL)(compiled + 1);
+ F_ARRAY *literals = untag_object(compiled->literals);
+ F_FIXNUM absolute_value = array_nth(literals,REL_ARGUMENT(rel));
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+ }
+}
+
+/* Update pointers to literals from compiled code. */
+void update_literal_references(F_CODE_BLOCK *compiled)
+{
+ iterate_relocations(compiled,update_literal_references_step);
+ flush_icache_for(compiled);
+}
+
+/* Copy all literals referenced from a code block to newspace. Only for
+aging and nursery collections */
+void copy_literal_references(F_CODE_BLOCK *compiled)
+{
+ if(collecting_gen >= compiled->last_scan)
+ {
+ if(collecting_accumulation_gen_p())
+ compiled->last_scan = collecting_gen;
+ else
+ compiled->last_scan = collecting_gen + 1;
+
+ /* initialize chase pointer */
+ CELL scan = newspace->here;
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+
+ /* do some tracing so that all reachable literals are now
+ at their final address */
+ copy_reachable_objects(scan,&newspace->here);
+
+ update_literal_references(compiled);
+ }
+}
+
+CELL object_xt(CELL obj)
+{
+ if(type_of(obj) == WORD_TYPE)
+ return (CELL)untag_word(obj)->xt;
+ else
+ return (CELL)untag_quotation(obj)->xt;
+}
+
+void update_word_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
+{
+ if(REL_TYPE(rel) == RT_XT)
+ {
+ CELL offset = rel->offset + (CELL)(compiled + 1);
+ F_ARRAY *literals = untag_object(compiled->literals);
+ CELL xt = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
+ store_address_in_code_block(REL_CLASS(rel),offset,xt);
+ }
+}
+
+/* Relocate new code blocks completely; updating references to literals,
+dlsyms, and words. For all other words in the code heap, we only need
+to update references to other words, without worrying about literals
+or dlsyms. */
+void update_word_references(F_CODE_BLOCK *compiled)
+{
+ if(compiled->needs_fixup)
+ relocate_code_block(compiled);
+ else
+ {
+ iterate_relocations(compiled,update_word_references_step);
+ flush_icache_for(compiled);
+ }
+}
+
+/* Update references to words. This is done after a new code block
+is added to the heap. */
+
+/* Mark all literals referenced from a word XT. Only for tenured
+collections */
+void mark_code_block(F_CODE_BLOCK *compiled)
+{
+ mark_block(compiled_to_block(compiled));
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+
+ flush_icache_for(compiled);
+}
+
+void mark_stack_frame_step(F_STACK_FRAME *frame)
+{
+ mark_code_block(frame_code(frame));
+}
+
+/* Mark code blocks executing in currently active stack frames. */
+void mark_active_blocks(F_CONTEXT *stacks)
+{
+ if(collecting_gen == TENURED)
+ {
+ CELL top = (CELL)stacks->callstack_top;
+ CELL bottom = (CELL)stacks->callstack_bottom;
+
+ iterate_callstack(top,bottom,mark_stack_frame_step);
+ }
+}
+
+void mark_object_code_block(CELL scan)
+{
+ F_WORD *word;
+ F_QUOTATION *quot;
+ F_CALLSTACK *stack;
+
+ switch(object_type(scan))
+ {
+ case WORD_TYPE:
+ word = (F_WORD *)scan;
+ mark_code_block(word->code);
+ if(word->profiling)
+ mark_code_block(word->profiling);
+ break;
+ case QUOTATION_TYPE:
+ quot = (F_QUOTATION *)scan;
+ if(quot->compiledp != F)
+ mark_code_block(quot->code);
+ break;
+ case CALLSTACK_TYPE:
+ stack = (F_CALLSTACK *)scan;
+ iterate_callstack_object(stack,mark_stack_frame_step);
+ break;
+ }
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol(void)
+{
+ general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
+{
+ CELL arg = REL_ARGUMENT(rel);
+ CELL symbol = array_nth(literals,arg);
+ CELL library = array_nth(literals,arg + 1);
+
+ F_DLL *dll = (library == F ? NULL : untag_dll(library));
+
+ if(dll != NULL && !dll->dll)
+ return undefined_symbol;
+
+ if(type_of(symbol) == BYTE_ARRAY_TYPE)
+ {
+ F_SYMBOL *name = alien_offset(symbol);
+ void *sym = ffi_dlsym(dll,name);
+
+ if(sym)
+ return sym;
+ }
+ else if(type_of(symbol) == ARRAY_TYPE)
+ {
+ CELL i;
+ F_ARRAY *names = untag_object(symbol);
+ for(i = 0; i < array_capacity(names); i++)
+ {
+ F_SYMBOL *name = alien_offset(array_nth(names,i));
+ void *sym = ffi_dlsym(dll,name);
+
+ if(sym)
+ return sym;
+ }
+ }
+
+ return undefined_symbol;
+}
+
+/* Compute an address to store at a relocation */
+void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
+{
+ CELL offset = rel->offset + (CELL)(compiled + 1);
+ F_ARRAY *literals = untag_object(compiled->literals);
+ F_FIXNUM absolute_value;
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ absolute_value = (CELL)primitives[REL_ARGUMENT(rel)];
+ break;
+ case RT_DLSYM:
+ absolute_value = (CELL)get_rel_symbol(rel,literals);
+ break;
+ case RT_IMMEDIATE:
+ absolute_value = array_nth(literals,REL_ARGUMENT(rel));
+ break;
+ case RT_XT:
+ absolute_value = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
+ break;
+ case RT_HERE:
+ absolute_value = rel->offset + (CELL)(compiled + 1) + (short)REL_ARGUMENT(rel);
+ break;
+ case RT_LABEL:
+ absolute_value = (CELL)(compiled + 1) + REL_ARGUMENT(rel);
+ break;
+ case RT_STACK_CHAIN:
+ absolute_value = (CELL)&stack_chain;
+ break;
+ default:
+ critical_error("Bad rel type",rel->type);
+ return; /* Can't happen */
+ }
+
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+}
+
+/* Perform all fixups on a code block */
+void relocate_code_block(F_CODE_BLOCK *compiled)
+{
+ compiled->last_scan = NURSERY;
+ compiled->needs_fixup = false;
+ iterate_relocations(compiled,relocate_code_block_step);
+ flush_icache_for(compiled);
+}
+
+/* Fixup labels. This is done at compile time, not image load time */
+void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled)
+{
+ CELL i;
+ CELL size = array_capacity(labels);
+
+ for(i = 0; i < size; i += 3)
+ {
+ CELL class = to_fixnum(array_nth(labels,i));
+ CELL offset = to_fixnum(array_nth(labels,i + 1));
+ CELL target = to_fixnum(array_nth(labels,i + 2));
+
+ store_address_in_code_block(class,
+ offset + (CELL)(compiled + 1),
+ target + (CELL)(compiled + 1));
+ }
+}
+
+/* Write a sequence of integers to memory, with 'format' bytes per integer */
+void deposit_integers(CELL here, F_ARRAY *array, CELL format)
+{
+ CELL count = array_capacity(array);
+ CELL i;
+
+ for(i = 0; i < count; i++)
+ {
+ F_FIXNUM value = to_fixnum(array_nth(array,i));
+ if(format == 1)
+ bput(here + i,value);
+ else if(format == sizeof(unsigned int))
+ *(unsigned int *)(here + format * i) = value;
+ else if(format == sizeof(CELL))
+ *(CELL *)(here + format * i) = value;
+ else
+ critical_error("Bad format in deposit_integers()",format);
+ }
+}
+
+bool stack_traces_p(void)
+{
+ return to_boolean(userenv[STACK_TRACES_ENV]);
+}
+
+CELL compiled_code_format(void)
+{
+ return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
+}
+
+/* Might GC */
+void *allot_code_block(CELL size)
+{
+ void *start = heap_allot(&code_heap,size);
+
+ /* If allocation failed, do a code GC */
+ if(start == NULL)
+ {
+ gc();
+ start = heap_allot(&code_heap,size);
+
+ /* Insufficient room even after code GC, give up */
+ if(start == NULL)
+ {
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
+
+ print_string("Code heap stats:\n");
+ print_string("Used: "); print_cell(used); nl();
+ print_string("Total free space: "); print_cell(total_free); nl();
+ print_string("Largest free block: "); print_cell(max_free); nl();
+ fatal_error("Out of memory in add-compiled-block",0);
+ }
+ }
+
+ return start;
+}
+
+/* Might GC */
+F_CODE_BLOCK *add_compiled_block(
+ CELL type,
+ F_ARRAY *code,
+ F_ARRAY *labels,
+ CELL relocation,
+ CELL literals)
+{
+ CELL code_format = compiled_code_format();
+ CELL code_length = align8(array_capacity(code) * code_format);
+
+ REGISTER_ROOT(literals);
+ REGISTER_ROOT(relocation);
+ REGISTER_UNTAGGED(code);
+ REGISTER_UNTAGGED(labels);
+
+ F_CODE_BLOCK *compiled = allot_code_block(sizeof(F_CODE_BLOCK) + code_length);
+
+ UNREGISTER_UNTAGGED(labels);
+ UNREGISTER_UNTAGGED(code);
+ UNREGISTER_ROOT(relocation);
+ UNREGISTER_ROOT(literals);
+
+ /* compiled header */
+ compiled->type = type;
+ compiled->last_scan = NURSERY;
+ compiled->needs_fixup = true;
+ compiled->code_length = code_length;
+ compiled->literals = literals;
+ compiled->relocation = relocation;
+
+ /* code */
+ deposit_integers((CELL)(compiled + 1),code,code_format);
+
+ /* fixup labels */
+ if(labels) fixup_labels(labels,code_format,compiled);
+
+ /* next time we do a minor GC, we have to scan the code heap for
+ literals */
+ last_code_heap_scan = NURSERY;
+
+ return compiled;
+}
--- /dev/null
+typedef enum {
+ /* arg is a primitive number */
+ RT_PRIMITIVE,
+ /* arg is a literal table index, holding an array pair (symbol/dll) */
+ RT_DLSYM,
+ /* a pointer to a compiled word reference */
+ RT_DISPATCH,
+ /* a compiled word reference */
+ RT_XT,
+ /* current offset */
+ RT_HERE,
+ /* a local label */
+ RT_LABEL,
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN
+} F_RELTYPE;
+
+typedef enum {
+ /* absolute address in a 64-bit location */
+ RC_ABSOLUTE_CELL,
+ /* absolute address in a 32-bit location */
+ RC_ABSOLUTE,
+ /* relative address in a 32-bit location */
+ RC_RELATIVE,
+ /* relative address in a PowerPC LIS/ORI sequence */
+ RC_ABSOLUTE_PPC_2_2,
+ /* relative address in a PowerPC LWZ/STW/BC instruction */
+ RC_RELATIVE_PPC_2,
+ /* relative address in a PowerPC B/BL instruction */
+ RC_RELATIVE_PPC_3,
+ /* relative address in an ARM B/BL instruction */
+ RC_RELATIVE_ARM_3,
+ /* pointer to address in an ARM LDR/STR instruction */
+ RC_INDIRECT_ARM,
+ /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
+ RC_INDIRECT_ARM_PC
+} F_RELCLASS;
+
+#define REL_RELATIVE_PPC_2_MASK 0xfffc
+#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
+#define REL_INDIRECT_ARM_MASK 0xfff
+#define REL_RELATIVE_ARM_3_MASK 0xffffff
+
+/* the rel type is built like a cell to avoid endian-specific code in
+the compiler */
+#define REL_TYPE(r) ((r)->type & 0x000000ff)
+#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
+#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
+
+/* code relocation consists of a table of entries for each fixup */
+typedef struct {
+ unsigned int type;
+ unsigned int offset;
+} F_REL;
+
+void flush_icache_for(F_CODE_BLOCK *compiled);
+
+typedef void (*RELOCATION_ITERATOR)(F_REL *rel, F_CODE_BLOCK *compiled);
+
+void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
+
+void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
+
+void relocate_code_block(F_CODE_BLOCK *compiled);
+
+void update_literal_references(F_CODE_BLOCK *compiled);
+
+void copy_literal_references(F_CODE_BLOCK *compiled);
+
+void update_word_references(F_CODE_BLOCK *compiled);
+
+void mark_code_block(F_CODE_BLOCK *compiled);
+
+void mark_active_blocks(F_CONTEXT *stacks);
+
+void mark_object_code_block(CELL scan);
+
+void relocate_code_block(F_CODE_BLOCK *relocating);
+
+CELL compiled_code_format(void);
+
+bool stack_traces_p(void);
+
+F_CODE_BLOCK *add_compiled_block(
+ CELL type,
+ F_ARRAY *code,
+ F_ARRAY *labels,
+ CELL relocation,
+ CELL literals);
heap->free_list = NULL;
}
-/* Allocate a code heap during startup */
-void init_code_heap(CELL size)
-{
- new_heap(&code_heap,size);
-}
-
-bool in_code_heap_p(CELL ptr)
-{
- return (ptr >= code_heap.segment->start
- && ptr <= code_heap.segment->end);
-}
-
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
}
/* Allocate a block of memory from the mark and sweep GC heap */
-CELL heap_allot(F_HEAP *heap, CELL size)
+void *heap_allot(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_BLOCK *scan = heap->free_list;
/* this is our new block */
scan->status = B_ALLOCATED;
- return (CELL)(scan + 1);
+ return scan + 1;
}
- return 0;
+ return NULL;
+}
+
+void mark_block(F_BLOCK *block)
+{
+ /* If already marked, do nothing */
+ switch(block->status)
+ {
+ case B_MARKED:
+ return;
+ case B_ALLOCATED:
+ block->status = B_MARKED;
+ break;
+ default:
+ critical_error("Marking the wrong block",(CELL)block);
+ break;
+ }
}
-/* If in the middle of code GC, we have to grow the heap, GC restarts from
+/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
void unmark_marked(F_HEAP *heap)
{
return heap->segment->size;
}
-/* Apply a function to every code block */
-void iterate_code_heap(CODE_HEAP_ITERATOR iter)
-{
- F_BLOCK *scan = first_block(&code_heap);
-
- while(scan)
- {
- if(scan->status != B_FREE)
- iterate_code_heap_step(block_to_compiled(scan),iter);
- scan = next_block(&code_heap,scan);
- }
-}
-
-/* Copy all literals referenced from a code block to newspace */
-void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
-{
- if(collecting_gen >= compiled->last_scan)
- {
- CELL scan;
- CELL literal_end = literals_start + compiled->literals_length;
-
- if(collecting_accumulation_gen_p())
- compiled->last_scan = collecting_gen;
- else
- compiled->last_scan = collecting_gen + 1;
-
- for(scan = literals_start; scan < literal_end; scan += CELLS)
- copy_handle((CELL*)scan);
-
- if(compiled->relocation != F)
- {
- copy_handle(&compiled->relocation);
-
- F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
-
- F_REL *rel = (F_REL *)(relocation + 1);
- F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
-
- while(rel < rel_end)
- {
- if(REL_TYPE(rel) == RT_IMMEDIATE)
- {
- CELL offset = rel->offset + code_start;
- F_FIXNUM absolute_value = get(CREF(literals_start,REL_ARGUMENT(rel)));
- apply_relocation(REL_CLASS(rel),offset,absolute_value);
- }
-
- rel++;
- }
- }
-
- flush_icache(code_start,literals_start - code_start);
- }
-}
-
-/* Copy literals referenced from all code blocks to newspace */
-void collect_literals(void)
-{
- iterate_code_heap(collect_literals_step);
-}
-
-/* Mark all XTs and literals referenced from a word XT */
-void recursive_mark(F_BLOCK *block)
-{
- /* If already marked, do nothing */
- switch(block->status)
- {
- case B_MARKED:
- return;
- case B_ALLOCATED:
- block->status = B_MARKED;
- break;
- default:
- critical_error("Marking the wrong block",(CELL)block);
- break;
- }
-
- F_COMPILED *compiled = block_to_compiled(block);
- iterate_code_heap_step(compiled,collect_literals_step);
-}
-
-/* Push the free space and total size of the code heap */
-void primitive_code_room(void)
-{
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
- dpush(tag_fixnum((code_heap.segment->size) / 1024));
- dpush(tag_fixnum(used / 1024));
- dpush(tag_fixnum(total_free / 1024));
- dpush(tag_fixnum(max_free / 1024));
-}
-
-/* Dump all code blocks for debugging */
-void dump_heap(F_HEAP *heap)
-{
- CELL size = 0;
-
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- char *status;
- switch(scan->status)
- {
- case B_FREE:
- status = "free";
- break;
- case B_ALLOCATED:
- size += object_size(block_to_compiled(scan)->relocation);
- status = "allocated";
- break;
- case B_MARKED:
- size += object_size(block_to_compiled(scan)->relocation);
- status = "marked";
- break;
- default:
- status = "invalid";
- break;
- }
-
- print_cell_hex((CELL)scan); print_string(" ");
- print_cell_hex(scan->size); print_string(" ");
- print_string(status); print_string("\n");
-
- scan = next_block(heap,scan);
- }
-
- print_cell(size); print_string(" bytes of relocation data\n");
-}
-
/* Compute where each block is going to go, after compaction */
CELL compute_heap_forwarding(F_HEAP *heap)
{
return address - heap->segment->start;
}
-F_COMPILED *forward_xt(F_COMPILED *compiled)
-{
- return block_to_compiled(compiled_to_block(compiled)->forwarding);
-}
-
-void forward_frame_xt(F_STACK_FRAME *frame)
-{
- CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
- F_COMPILED *forwarded = forward_xt(frame_code(frame));
- frame->xt = (XT)(forwarded + 1);
- FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
-}
-
-void forward_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
-
- word->code = forward_xt(word->code);
- if(word->profiling)
- word->profiling = forward_xt(word->profiling);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- quot->code = forward_xt(quot->code);
- }
- else if(type_of(obj) == CALLSTACK_TYPE)
- {
- F_CALLSTACK *stack = untag_object(obj);
- iterate_callstack_object(stack,forward_frame_xt);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
-/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- update_word_xt(word);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- set_quot_xt(quot,quot->code);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
void compact_heap(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
scan = next;
}
}
-
-/* Move all free space to the end of the code heap. This is not very efficient,
-since it makes several passes over the code and data heaps, but we only ever
-do this before saving a deployed image and exiting, so performaance is not
-critical here */
-void compact_code_heap(void)
-{
- /* Free all unreachable code blocks */
- gc();
-
- /* Figure out where the code heap blocks are going to end up */
- CELL size = compute_heap_forwarding(&code_heap);
-
- /* Update word and quotation code pointers */
- forward_object_xts();
-
- /* Actually perform the compaction */
- compact_heap(&code_heap);
-
- /* Update word and quotation XTs */
- fixup_object_xts();
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list(&code_heap,size);
-}
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
-CELL heap_allot(F_HEAP *heap, CELL size);
+void *heap_allot(F_HEAP *heap, CELL size);
+void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
+CELL compute_heap_forwarding(F_HEAP *heap);
+void compact_heap(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
{
return (F_BLOCK *)next;
}
-/* compiled code */
-F_HEAP code_heap;
-
-typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
-
-INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
-{
- CELL code_start = (CELL)(compiled + 1);
- CELL literals_start = code_start + compiled->code_length;
-
- iter(compiled,code_start,literals_start);
-}
-
-INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
-{
- return (F_BLOCK *)compiled - 1;
-}
-
-INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
-{
- return (F_COMPILED *)(block + 1);
-}
-
INLINE F_BLOCK *first_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->start;
{
return (F_BLOCK *)heap->segment->end;
}
-
-void init_code_heap(CELL size);
-bool in_code_heap_p(CELL ptr);
-void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-void collect_literals(void);
-void recursive_mark(F_BLOCK *block);
-void dump_heap(F_HEAP *heap);
-void compact_code_heap(void);
-
-void primitive_code_room(void);
#include "master.h"
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol(void)
+/* Allocate a code heap during startup */
+void init_code_heap(CELL size)
{
- general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+ new_heap(&code_heap,size);
}
-INLINE CELL get_literal(CELL literals_start, CELL num)
+bool in_code_heap_p(CELL ptr)
{
- return get(CREF(literals_start,num));
+ return (ptr >= code_heap.segment->start
+ && ptr <= code_heap.segment->end);
}
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(F_REL *rel, CELL literals_start)
+void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
- CELL arg = REL_ARGUMENT(rel);
- CELL symbol = get_literal(literals_start,arg);
- CELL library = get_literal(literals_start,arg + 1);
-
- F_DLL *dll = (library == F ? NULL : untag_dll(library));
-
- if(dll != NULL && !dll->dll)
- return undefined_symbol;
-
- if(type_of(symbol) == BYTE_ARRAY_TYPE)
- {
- F_SYMBOL *name = alien_offset(symbol);
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- else if(type_of(symbol) == ARRAY_TYPE)
- {
- CELL i;
- F_ARRAY *names = untag_object(symbol);
- for(i = 0; i < array_capacity(names); i++)
- {
- F_SYMBOL *name = alien_offset(array_nth(names,i));
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- }
-
- return undefined_symbol;
-}
-
-/* Compute an address to store at a relocation */
-INLINE CELL compute_code_rel(F_REL *rel,
- CELL code_start, CELL literals_start)
-{
- CELL obj;
-
- switch(REL_TYPE(rel))
- {
- case RT_PRIMITIVE:
- return (CELL)primitives[REL_ARGUMENT(rel)];
- case RT_DLSYM:
- return (CELL)get_rel_symbol(rel,literals_start);
- case RT_IMMEDIATE:
- return get(CREF(literals_start,REL_ARGUMENT(rel)));
- case RT_XT:
- obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
- if(type_of(obj) == WORD_TYPE)
- return (CELL)untag_word(obj)->xt;
- else
- return (CELL)untag_quotation(obj)->xt;
- case RT_HERE:
- return rel->offset + code_start + (short)REL_ARGUMENT(rel);
- case RT_LABEL:
- return code_start + REL_ARGUMENT(rel);
- case RT_STACK_CHAIN:
- return (CELL)&stack_chain;
- default:
- critical_error("Bad rel type",rel->type);
- return -1; /* Can't happen */
- }
-}
-
-/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-INLINE void reloc_set_2_2(CELL cell, CELL value)
-{
- put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
- put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
-}
-
-/* Store a value into a bitfield of a PowerPC instruction */
-INLINE void reloc_set_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
-{
- /* This is unaccurate but good enough */
- F_FIXNUM test = (F_FIXNUM)mask >> 1;
- if(value <= -test || value >= test)
- critical_error("Value does not fit inside relocation",0);
-
- u32 original = *(u32*)cell;
- original &= ~mask;
- *(u32*)cell = (original | ((value >> shift) & mask));
-}
-
-/* Perform a fixup on a code block */
-void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
-{
- F_FIXNUM relative_value = absolute_value - offset;
-
- switch(class)
- {
- case RC_ABSOLUTE_CELL:
- put(offset,absolute_value);
- break;
- case RC_ABSOLUTE:
- *(u32*)offset = absolute_value;
- break;
- case RC_RELATIVE:
- *(u32*)offset = relative_value - sizeof(u32);
- break;
- case RC_ABSOLUTE_PPC_2_2:
- reloc_set_2_2(offset,absolute_value);
- break;
- case RC_RELATIVE_PPC_2:
- reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
- break;
- case RC_RELATIVE_PPC_3:
- reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
- break;
- case RC_RELATIVE_ARM_3:
- reloc_set_masked(offset,relative_value - CELLS * 2,
- REL_RELATIVE_ARM_3_MASK,2);
- break;
- case RC_INDIRECT_ARM:
- reloc_set_masked(offset,relative_value - CELLS,
- REL_INDIRECT_ARM_MASK,0);
- break;
- case RC_INDIRECT_ARM_PC:
- reloc_set_masked(offset,relative_value - CELLS * 2,
- REL_INDIRECT_ARM_MASK,0);
- break;
- default:
- critical_error("Bad rel class",class);
- break;
- }
-}
-
-/* Perform all fixups on a code block */
-void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
-{
- compiled->last_scan = NURSERY;
-
- if(compiled->relocation != F)
- {
- F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
-
- F_REL *rel = (F_REL *)(relocation + 1);
- F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
-
- while(rel < rel_end)
- {
- CELL offset = rel->offset + code_start;
-
- F_FIXNUM absolute_value = compute_code_rel(
- rel,code_start,literals_start);
-
- apply_relocation(REL_CLASS(rel),offset,absolute_value);
-
- rel++;
- }
- }
-
- flush_icache(code_start,literals_start - code_start);
-}
-
-/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start)
-{
- CELL i;
- CELL size = array_capacity(labels);
-
- for(i = 0; i < size; i += 3)
- {
- CELL class = to_fixnum(array_nth(labels,i));
- CELL offset = to_fixnum(array_nth(labels,i + 1));
- CELL target = to_fixnum(array_nth(labels,i + 2));
-
- apply_relocation(class,
- offset + code_start,
- target + code_start);
- }
-}
-
-/* Write a sequence of integers to memory, with 'format' bytes per integer */
-void deposit_integers(CELL here, F_ARRAY *array, CELL format)
-{
- CELL count = array_capacity(array);
- CELL i;
-
- for(i = 0; i < count; i++)
- {
- F_FIXNUM value = to_fixnum(array_nth(array,i));
- if(format == 1)
- bput(here + i,value);
- else if(format == sizeof(unsigned int))
- *(unsigned int *)(here + format * i) = value;
- else if(format == CELLS)
- put(CREF(here,i),value);
- else
- critical_error("Bad format in deposit_integers()",format);
- }
-}
+ if(compiled->type != WORD_TYPE)
+ critical_error("bad param to set_word_xt",(CELL)compiled);
-/* Write a sequence of tagged pointers to memory */
-void deposit_objects(CELL here, F_ARRAY *array)
-{
- memcpy((void*)here,array + 1,array_capacity(array) * CELLS);
+ word->code = compiled;
+ word->optimizedp = T;
}
-bool stack_traces_p(void)
+/* Allocates memory */
+void default_word_code(F_WORD *word, bool relocate)
{
- return to_boolean(userenv[STACK_TRACES_ENV]);
-}
+ REGISTER_UNTAGGED(word);
+ jit_compile(word->def,relocate);
+ UNREGISTER_UNTAGGED(word);
-CELL compiled_code_format(void)
-{
- return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
+ word->code = untag_quotation(word->def)->code;
+ word->optimizedp = F;
}
-CELL allot_code_block(CELL size)
+/* Apply a function to every code block */
+void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
- CELL start = heap_allot(&code_heap,size);
+ F_BLOCK *scan = first_block(&code_heap);
- /* If allocation failed, do a code GC */
- if(start == 0)
+ while(scan)
{
- gc();
- start = heap_allot(&code_heap,size);
-
- /* Insufficient room even after code GC, give up */
- if(start == 0)
- {
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
-
- print_string("Code heap stats:\n");
- print_string("Used: "); print_cell(used); nl();
- print_string("Total free space: "); print_cell(total_free); nl();
- print_string("Largest free block: "); print_cell(max_free); nl();
- fatal_error("Out of memory in add-compiled-block",0);
- }
+ if(scan->status != B_FREE)
+ iter(block_to_compiled(scan));
+ scan = next_block(&code_heap,scan);
}
-
- return start;
}
-/* Might GC */
-F_COMPILED *add_compiled_block(
- CELL type,
- F_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- F_ARRAY *literals)
+/* Copy literals referenced from all code blocks to newspace. Only for
+aging and nursery collections */
+void copy_code_heap_roots(void)
{
- CELL code_format = compiled_code_format();
-
- CELL code_length = align8(array_capacity(code) * code_format);
- CELL literals_length = array_capacity(literals) * CELLS;
-
- REGISTER_ROOT(relocation);
- REGISTER_UNTAGGED(code);
- REGISTER_UNTAGGED(labels);
- REGISTER_UNTAGGED(literals);
-
- CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
-
- UNREGISTER_UNTAGGED(literals);
- UNREGISTER_UNTAGGED(labels);
- UNREGISTER_UNTAGGED(code);
- UNREGISTER_ROOT(relocation);
-
- /* compiled header */
- F_COMPILED *header = (void *)here;
- header->type = type;
- header->last_scan = NURSERY;
- header->code_length = code_length;
- header->literals_length = literals_length;
- header->relocation = relocation;
-
- here += sizeof(F_COMPILED);
-
- CELL code_start = here;
-
- /* code */
- deposit_integers(here,code,code_format);
- here += code_length;
-
- /* literals */
- deposit_objects(here,literals);
- here += literals_length;
-
- /* fixup labels */
- if(labels)
- fixup_labels(labels,code_format,code_start);
-
- /* next time we do a minor GC, we have to scan the code heap for
- literals */
- last_code_heap_scan = NURSERY;
-
- return header;
+ iterate_code_heap(copy_literal_references);
}
-void set_word_code(F_WORD *word, F_COMPILED *compiled)
+/* Update literals referenced from all code blocks. Only for tenured
+collections, done at the end. */
+void update_code_heap_roots(void)
{
- if(compiled->type != WORD_TYPE)
- critical_error("bad param to set_word_xt",(CELL)compiled);
-
- word->code = compiled;
- word->compiledp = T;
+ iterate_code_heap(update_literal_references);
}
-/* Allocates memory */
-void default_word_code(F_WORD *word, bool relocate)
+/* Update pointers to words referenced from all code blocks. Only after
+defining a new word. */
+void update_code_heap_words(void)
{
- REGISTER_UNTAGGED(word);
- jit_compile(word->def,relocate);
- UNREGISTER_UNTAGGED(word);
-
- word->code = untag_quotation(word->def)->code;
- word->compiledp = F;
+ iterate_code_heap(update_word_references);
}
void primitive_modify_code_heap(void)
{
- bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
CELL count = untag_fixnum_fast(alist->capacity);
+ if(count == 0)
+ return;
+
CELL i;
for(i = 0; i < count; i++)
{
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
- F_COMPILED *compiled = add_compiled_block(
+ F_CODE_BLOCK *compiled = add_compiled_block(
WORD_TYPE,
code,
labels,
relocation,
- literals);
+ tag_object(literals));
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
UNREGISTER_UNTAGGED(alist);
}
- /* If there were any interned words in the set, we relocate all XT
- references in the entire code heap. But if all the words are
- uninterned, it is impossible that other words reference them, so we
- only have to relocate the new words. This makes compile-call much
- more efficient */
- if(rescan_code_heap)
- iterate_code_heap(relocate_code_block);
- else
+ update_code_heap_words();
+}
+
+/* Push the free space and total size of the code heap */
+void primitive_code_room(void)
+{
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
+ dpush(tag_fixnum((code_heap.segment->size) / 1024));
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
+}
+
+F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
+{
+ return block_to_compiled(compiled_to_block(compiled)->forwarding);
+}
+
+void forward_frame_xt(F_STACK_FRAME *frame)
+{
+ CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
+ F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
+ frame->xt = (XT)(forwarded + 1);
+ FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
+}
+
+void forward_object_xts(void)
+{
+ begin_scan();
+
+ CELL obj;
+
+ while((obj = next_object()) != F)
{
- for(i = 0; i < count; i++)
+ if(type_of(obj) == WORD_TYPE)
{
- F_ARRAY *pair = untag_array(array_nth(alist,i));
- F_WORD *word = untag_word(array_nth(pair,0));
+ F_WORD *word = untag_object(obj);
- iterate_code_heap_step(word->code,relocate_code_block);
+ word->code = forward_xt(word->code);
+ if(word->profiling)
+ word->profiling = forward_xt(word->profiling);
+ }
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_object(obj);
+
+ if(quot->compiledp != F)
+ quot->code = forward_xt(quot->code);
+ }
+ else if(type_of(obj) == CALLSTACK_TYPE)
+ {
+ F_CALLSTACK *stack = untag_object(obj);
+ iterate_callstack_object(stack,forward_frame_xt);
}
}
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* Set the XT fields now that the heap has been compacted */
+void fixup_object_xts(void)
+{
+ begin_scan();
+
+ CELL obj;
+
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ {
+ F_WORD *word = untag_object(obj);
+ update_word_xt(word);
+ }
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_object(obj);
+
+ if(quot->compiledp != F)
+ set_quot_xt(quot,quot->code);
+ }
+ }
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* Move all free space to the end of the code heap. This is not very efficient,
+since it makes several passes over the code and data heaps, but we only ever
+do this before saving a deployed image and exiting, so performaance is not
+critical here */
+void compact_code_heap(void)
+{
+ /* Free all unreachable code blocks */
+ gc();
+
+ /* Figure out where the code heap blocks are going to end up */
+ CELL size = compute_heap_forwarding(&code_heap);
+
+ /* Update word and quotation code pointers */
+ forward_object_xts();
+
+ /* Actually perform the compaction */
+ compact_heap(&code_heap);
+
+ /* Update word and quotation XTs */
+ fixup_object_xts();
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ build_free_list(&code_heap,size);
}
-typedef enum {
- /* arg is a primitive number */
- RT_PRIMITIVE,
- /* arg is a literal table index, holding an array pair (symbol/dll) */
- RT_DLSYM,
- /* a pointer to a compiled word reference */
- RT_DISPATCH,
- /* a compiled word reference */
- RT_XT,
- /* current offset */
- RT_HERE,
- /* a local label */
- RT_LABEL,
- /* immediate literal */
- RT_IMMEDIATE,
- /* address of stack_chain var */
- RT_STACK_CHAIN
-} F_RELTYPE;
+/* compiled code */
+F_HEAP code_heap;
-typedef enum {
- /* absolute address in a 64-bit location */
- RC_ABSOLUTE_CELL,
- /* absolute address in a 32-bit location */
- RC_ABSOLUTE,
- /* relative address in a 32-bit location */
- RC_RELATIVE,
- /* relative address in a PowerPC LIS/ORI sequence */
- RC_ABSOLUTE_PPC_2_2,
- /* relative address in a PowerPC LWZ/STW/BC instruction */
- RC_RELATIVE_PPC_2,
- /* relative address in a PowerPC B/BL instruction */
- RC_RELATIVE_PPC_3,
- /* relative address in an ARM B/BL instruction */
- RC_RELATIVE_ARM_3,
- /* pointer to address in an ARM LDR/STR instruction */
- RC_INDIRECT_ARM,
- /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
- RC_INDIRECT_ARM_PC
-} F_RELCLASS;
+INLINE F_BLOCK *compiled_to_block(F_CODE_BLOCK *compiled)
+{
+ return (F_BLOCK *)compiled - 1;
+}
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+INLINE F_CODE_BLOCK *block_to_compiled(F_BLOCK *block)
+{
+ return (F_CODE_BLOCK *)(block + 1);
+}
-/* the rel type is built like a cell to avoid endian-specific code in
-the compiler */
-#define REL_TYPE(r) ((r)->type & 0x000000ff)
-#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
-#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
+void init_code_heap(CELL size);
-/* code relocation consists of a table of entries for each fixup */
-typedef struct {
- unsigned int type;
- unsigned int offset;
-} F_REL;
+bool in_code_heap_p(CELL ptr);
-#define CREF(array,i) ((CELL)(array) + CELLS * (i))
-
-void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value);
+void default_word_code(F_WORD *word, bool relocate);
-void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
+void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
-void default_word_code(F_WORD *word, bool relocate);
+typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
-void set_word_code(F_WORD *word, F_COMPILED *compiled);
+void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-F_COMPILED *add_compiled_block(
- CELL type,
- F_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- F_ARRAY *literals);
+void copy_code_heap_roots(void);
-CELL compiled_code_format(void);
-bool stack_traces_p(void);
+void update_code_heap_roots(void);
void primitive_modify_code_heap(void);
+
+void primitive_code_room(void);
+
+void compact_code_heap(void);
#include "master.h"
-CELL init_zone(F_ZONE *z, CELL size, CELL start)
-{
- z->size = size;
- z->start = z->here = start;
- z->end = start + size;
- return z->end;
-}
-
-void init_card_decks(void)
-{
- CELL start = align(data_heap->segment->start,DECK_SIZE);
- allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
- cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
- decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
-}
-
-F_DATA_HEAP *alloc_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size)
-{
- young_size = align(young_size,DECK_SIZE);
- aging_size = align(aging_size,DECK_SIZE);
- tenured_size = align(tenured_size,DECK_SIZE);
-
- F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
- data_heap->young_size = young_size;
- data_heap->aging_size = aging_size;
- data_heap->tenured_size = tenured_size;
- data_heap->gen_count = gens;
-
- CELL total_size;
- if(data_heap->gen_count == 2)
- total_size = young_size + 2 * tenured_size;
- else if(data_heap->gen_count == 3)
- total_size = young_size + 2 * aging_size + 2 * tenured_size;
- else
- {
- fatal_error("Invalid number of generations",data_heap->gen_count);
- return NULL; /* can't happen */
- }
-
- total_size += DECK_SIZE;
-
- data_heap->segment = alloc_segment(total_size);
-
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
-
- CELL cards_size = total_size >> CARD_BITS;
- data_heap->allot_markers = safe_malloc(cards_size);
- data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
-
- data_heap->cards = safe_malloc(cards_size);
- data_heap->cards_end = data_heap->cards + cards_size;
-
- CELL decks_size = total_size >> DECK_BITS;
- data_heap->decks = safe_malloc(decks_size);
- data_heap->decks_end = data_heap->decks + decks_size;
-
- CELL alloter = align(data_heap->segment->start,DECK_SIZE);
-
- alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
-
- if(data_heap->gen_count == 3)
- {
- alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
- }
-
- if(data_heap->gen_count >= 2)
- {
- alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
- }
-
- if(data_heap->segment->end - alloter > DECK_SIZE)
- critical_error("Bug in alloc_data_heap",alloter);
-
- return data_heap;
-}
-
-F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
-{
- CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
-
- return alloc_data_heap(data_heap->gen_count,
- data_heap->young_size,
- data_heap->aging_size,
- new_tenured_size);
-}
-
-void dealloc_data_heap(F_DATA_HEAP *data_heap)
-{
- dealloc_segment(data_heap->segment);
- free(data_heap->generations);
- free(data_heap->semispaces);
- free(data_heap->allot_markers);
- free(data_heap->cards);
- free(data_heap->decks);
- free(data_heap);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
- memset(first_card,0,last_card - first_card);
-}
-
-void clear_decks(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
- F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
- memset(first_deck,0,last_deck - first_deck);
-}
-
-void clear_allot_markers(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
-}
-
-void set_data_heap(F_DATA_HEAP *data_heap_)
-{
- data_heap = data_heap_;
- nursery = data_heap->generations[NURSERY];
- init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
-}
-
-void gc_reset(void)
-{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
- memset(&gc_stats[i],0,sizeof(F_GC_STATS));
-
- cards_scanned = 0;
- decks_scanned = 0;
- code_heap_scans = 0;
-}
-
-void init_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size,
- bool secure_gc_)
-{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
-
- gc_locals_region = alloc_segment(getpagesize());
- gc_locals = gc_locals_region->start - CELLS;
-
- extra_roots_region = alloc_segment(getpagesize());
- extra_roots = extra_roots_region->start - CELLS;
-
- secure_gc = secure_gc_;
-
- gc_reset();
-}
-
-/* Size of the object pointed to by a tagged pointer */
-CELL object_size(CELL tagged)
-{
- if(immediate_p(tagged))
- return 0;
- else
- return untagged_object_size(UNTAG(tagged));
-}
-
-/* Size of the object pointed to by an untagged pointer */
-CELL untagged_object_size(CELL pointer)
-{
- return align8(unaligned_object_size(pointer));
-}
-
-/* Size of the data area of an object pointed to by an untagged pointer */
-CELL unaligned_object_size(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- case ARRAY_TYPE:
- case BIGNUM_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case BYTE_ARRAY_TYPE:
- return byte_array_size(
- byte_array_capacity((F_BYTE_ARRAY*)pointer));
- case STRING_TYPE:
- return string_size(string_capacity((F_STRING*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION);
- case WORD_TYPE:
- return sizeof(F_WORD);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
- case FLOAT_TYPE:
- return sizeof(F_FLOAT);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
- case DLL_TYPE:
- return sizeof(F_DLL);
- case ALIEN_TYPE:
- return sizeof(F_ALIEN);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- case CALLSTACK_TYPE:
- return callstack_size(
- untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-void primitive_size(void)
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
-/* Push memory usage statistics in data heap */
-void primitive_data_room(void)
-{
- F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
- int gen;
-
- dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
- dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
-
- for(gen = 0; gen < data_heap->gen_count; gen++)
- {
- F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
- set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
- set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
- }
-
- dpush(tag_object(a));
-}
-
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan(void)
-{
- heap_scan_ptr = data_heap->generations[TENURED].start;
- gc_off = true;
-}
-
-void primitive_begin_scan(void)
-{
- gc();
- begin_scan();
-}
-
-CELL next_object(void)
-{
- if(!gc_off)
- general_error(ERROR_HEAP_SCAN,F,F,NULL);
-
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
- CELL type;
-
- if(heap_scan_ptr >= data_heap->generations[TENURED].here)
- return F;
-
- type = untag_header(value);
- heap_scan_ptr += untagged_object_size(heap_scan_ptr);
-
- return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
-}
-
-/* Push object at heap scan cursor and advance; pushes f when done */
-void primitive_next_object(void)
-{
- dpush(next_object());
-}
-
-/* Re-enables GC */
-void primitive_end_scan(void)
-{
- gc_off = false;
-}
-
/* Scan all the objects in the card */
-void collect_card(F_CARD *ptr, CELL gen, CELL here)
+void copy_card(F_CARD *ptr, CELL gen, CELL here)
{
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
if(here < card_end)
card_end = here;
- collect_next_loop(card_scan,&card_end);
+ copy_reachable_objects(card_scan,&card_end);
cards_scanned++;
}
-void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
+void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
F_CARD *first_card = DECK_TO_CARD(deck);
F_CARD *last_card = DECK_TO_CARD(deck + 1);
{
if(ptr[card] & mask)
{
- collect_card(&ptr[card],gen,here);
+ copy_card(&ptr[card],gen,here);
ptr[card] &= ~unmask;
}
}
}
/* Copy all newspace objects referenced from marked cards to the destination */
-void collect_gen_cards(CELL gen)
+void copy_gen_cards(CELL gen)
{
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
unmask = CARD_MARK_MASK;
else
{
- critical_error("bug in collect_gen_cards",gen);
+ critical_error("bug in copy_gen_cards",gen);
return;
}
}
}
else
{
- critical_error("bug in collect_gen_cards",gen);
+ critical_error("bug in copy_gen_cards",gen);
return;
}
{
if(*ptr & mask)
{
- collect_card_deck(ptr,gen,mask,unmask);
+ copy_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask;
}
}
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-void collect_cards(void)
+void copy_cards(void)
{
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
- collect_gen_cards(i);
+ copy_gen_cards(i);
}
/* Copy all tagged pointers in a range of memory */
-void collect_stack(F_SEGMENT *region, CELL top)
+void copy_stack_elements(F_SEGMENT *region, CELL top)
{
CELL ptr = region->start;
copy_handle((CELL*)ptr);
}
-void collect_stack_frame(F_STACK_FRAME *frame)
-{
- recursive_mark(compiled_to_block(frame_code(frame)));
-}
-
-/* The base parameter allows us to adjust for a heap-allocated
-callstack snapshot */
-void collect_callstack(F_CONTEXT *stacks)
-{
- if(collecting_gen == TENURED)
- {
- CELL top = (CELL)stacks->callstack_top;
- CELL bottom = (CELL)stacks->callstack_bottom;
-
- iterate_callstack(top,bottom,collect_stack_frame);
- }
-}
-
-void collect_gc_locals(void)
+void copy_registered_locals(void)
{
CELL ptr = gc_locals_region->start;
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered with REGISTER_ROOT */
-void collect_roots(void)
+void copy_roots(void)
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
- collect_gc_locals();
- collect_stack(extra_roots_region,extra_roots);
+ copy_registered_locals();
+ copy_stack_elements(extra_roots_region,extra_roots);
save_stacks();
F_CONTEXT *stacks = stack_chain;
while(stacks)
{
- collect_stack(stacks->datastack_region,stacks->datastack);
- collect_stack(stacks->retainstack_region,stacks->retainstack);
+ copy_stack_elements(stacks->datastack_region,stacks->datastack);
+ copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
- collect_callstack(stacks);
+ mark_active_blocks(stacks);
stacks = stacks->next;
}
*handle = copy_object(pointer);
}
-/* The number of cells from the start of the object which should be scanned by
-the GC. Some types have a binary payload at the end (string, word, DLL) which
-we ignore. */
-CELL binary_payload_start(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- /* these objects do not refer to other objects at all */
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- case CALLSTACK_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(F_WORD) - CELLS * 3;
- case ALIEN_TYPE:
- return CELLS * 3;
- case DLL_TYPE:
- return CELLS * 2;
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION) - CELLS * 2;
- case STRING_TYPE:
- return sizeof(F_STRING);
- /* everything else consists entirely of pointers */
- case ARRAY_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-void do_code_slots(CELL scan)
-{
- F_WORD *word;
- F_QUOTATION *quot;
- F_CALLSTACK *stack;
-
- switch(object_type(scan))
- {
- case WORD_TYPE:
- word = (F_WORD *)scan;
- recursive_mark(compiled_to_block(word->code));
- if(word->profiling)
- recursive_mark(compiled_to_block(word->profiling));
- break;
- case QUOTATION_TYPE:
- quot = (F_QUOTATION *)scan;
- if(quot->compiledp != F)
- recursive_mark(compiled_to_block(quot->code));
- break;
- case CALLSTACK_TYPE:
- stack = (F_CALLSTACK *)scan;
- iterate_callstack_object(stack,collect_stack_frame);
- break;
- }
-}
-
-CELL collect_next_nursery(CELL scan)
+CELL copy_next_from_nursery(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
return scan + untagged_object_size(scan);
}
-CELL collect_next_aging(CELL scan)
+CELL copy_next_from_aging(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
return scan + untagged_object_size(scan);
}
-/* This function is performance-critical */
-CELL collect_next_tenured(CELL scan)
+CELL copy_next_from_tenured(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
}
}
- do_code_slots(scan);
+ mark_object_code_block(scan);
return scan + untagged_object_size(scan);
}
-void collect_next_loop(CELL scan, CELL *end)
+void copy_reachable_objects(CELL scan, CELL *end)
{
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
{
while(scan < *end)
- scan = collect_next_nursery(scan);
+ scan = copy_next_from_nursery(scan);
}
else if(HAVE_AGING_P && collecting_gen == AGING)
{
while(scan < *end)
- scan = collect_next_aging(scan);
+ scan = copy_next_from_aging(scan);
}
else if(collecting_gen == TENURED)
{
while(scan < *end)
- scan = collect_next_tenured(scan);
+ scan = copy_next_from_tenured(scan);
}
}
-INLINE void reset_generation(CELL i)
-{
- F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
-
- z->here = z->start;
- if(secure_gc)
- memset((void*)z->start,69,z->size);
-}
-
-/* After garbage collection, any generations which are now empty need to have
-their allocation pointers and cards reset. */
-void reset_generations(CELL from, CELL to)
-{
- CELL i;
- for(i = from; i <= to; i++)
- reset_generation(i);
-
- clear_cards(from,to);
- clear_decks(from,to);
- clear_allot_markers(from,to);
-}
-
/* Prepare to start copying reachable objects into an unused zone */
void begin_gc(CELL requested_bytes)
{
CELL scan = newspace->here;
/* collect objects referenced from stacks and environment */
- collect_roots();
+ copy_roots();
/* collect objects referenced from older generations */
- collect_cards();
+ copy_cards();
+ /* do some tracing */
+ copy_reachable_objects(scan,&newspace->here);
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
{
- if(collecting_gen != TENURED)
- {
-
- /* if we are doing code GC, then we will copy over
- literals from any code block which gets marked as live.
- if we are not doing code GC, just consider all literals
- as roots. */
- code_heap_scans++;
-
- collect_literals();
- }
+ code_heap_scans++;
+
+ if(collecting_gen == TENURED)
+ update_code_heap_roots();
+ else
+ copy_code_heap_roots();
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
last_code_heap_scan = collecting_gen + 1;
}
- collect_next_loop(scan,&newspace->here);
-
CELL gc_elapsed = (current_micros() - start);
end_gc(gc_elapsed);
dpush(stats);
}
-void primitive_gc_reset(void)
+void clear_gc_stats(void)
{
- gc_reset();
+ int i;
+ for(i = 0; i < MAX_GEN_COUNT; i++)
+ memset(&gc_stats[i],0,sizeof(F_GC_STATS));
+
+ cards_scanned = 0;
+ decks_scanned = 0;
+ code_heap_scans = 0;
+}
+
+void primitive_clear_gc_stats(void)
+{
+ clear_gc_stats();
}
void primitive_become(void)
compile_all_words();
}
-
-CELL find_all_words(void)
-{
- GROWABLE_ARRAY(words);
-
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ARRAY_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_ARRAY_TRIM(words);
-
- return words;
-}
-/* Set by the -S command line argument */
-bool secure_gc;
-
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-F_SEGMENT *alloc_segment(CELL size);
-void dealloc_segment(F_SEGMENT *block);
-
-CELL untagged_object_size(CELL pointer);
-CELL unaligned_object_size(CELL pointer);
-CELL object_size(CELL pointer);
-CELL binary_payload_start(CELL pointer);
-void begin_scan(void);
-CELL next_object(void);
-
-void primitive_data_room(void);
-void primitive_size(void);
-void primitive_begin_scan(void);
-void primitive_next_object(void);
-void primitive_end_scan(void);
-
void gc(void);
DLLEXPORT void minor_gc(void);
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* allocation pointer is 'here'; its offset is hardcoded in the
- compiler backends, see core/compiler/.../allot.factor */
- CELL start;
- CELL here;
- CELL size;
- CELL end;
-} F_ZONE;
-
-typedef struct {
- F_SEGMENT *segment;
-
- CELL young_size;
- CELL aging_size;
- CELL tenured_size;
-
- CELL gen_count;
-
- F_ZONE *generations;
- F_ZONE* semispaces;
-
- CELL *allot_markers;
- CELL *allot_markers_end;
-
- CELL *cards;
- CELL *cards_end;
-
- CELL *decks;
- CELL *decks_end;
-} F_DATA_HEAP;
-
-F_DATA_HEAP *data_heap;
-
-/* card marking write barrier. a card is a byte storing a mark flag,
-and the offset (in cells) of the first object in the card.
-
-the mark flag is set by the write barrier when an object in the
-card has a slot written to.
-
-the offset of the first object is set by the allocator. */
-
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
-typedef u8 F_CARD;
-
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-DLLEXPORT CELL cards_offset;
-
-#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
-#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
-
-typedef u8 F_DECK;
-
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
-
-DLLEXPORT CELL decks_offset;
-
-#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
-#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
-
-#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
-
-#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
-#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
-
-#define INVALID_ALLOT_MARKER 0xff
-
-DLLEXPORT CELL allot_markers_offset;
-
-void init_card_decks(void);
-
-/* the write barrier must be called any time we are potentially storing a
-pointer from an older generation to a younger one */
-INLINE void write_barrier(CELL address)
-{
- *ADDR_TO_CARD(address) = CARD_MARK_MASK;
- *ADDR_TO_DECK(address) = CARD_MARK_MASK;
-}
-
-#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
-
-INLINE void set_slot(CELL obj, CELL slot, CELL value)
-{
- put(SLOT(obj,slot),value);
- write_barrier(obj);
-}
-
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
-{
- F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = (address & ADDR_CARD_MASK);
-}
-
-void clear_cards(CELL from, CELL to);
-void collect_cards(void);
-
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-#define HAVE_NURSERY_P (data_heap->gen_count>1)
-/* where objects hang around */
-#define AGING (data_heap->gen_count-2)
-#define HAVE_AGING_P (data_heap->gen_count>2)
-/* the oldest generation */
-#define TENURED (data_heap->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
-
/* used during garbage collection only */
-F_ZONE *newspace;
-/* new objects are allocated here */
-DLLEXPORT F_ZONE nursery;
-
-INLINE bool in_zone(F_ZONE *z, CELL pointer)
-{
- return pointer >= z->start && pointer < z->end;
-}
+F_ZONE *newspace;
+bool performing_gc;
+CELL collecting_gen;
-CELL init_zone(F_ZONE *z, CELL size, CELL base);
+/* if true, we collecting AGING space for the second time, so if it is still
+full, we go on to collect TENURED */
+bool collecting_aging_again;
-void init_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size,
- bool secure_gc_);
+/* in case a generation fills up in the middle of a gc, we jump back
+up to try collecting the next generation. */
+jmp_buf gc_jmp;
/* statistics */
typedef struct {
u64 decks_scanned;
CELL code_heap_scans;
-/* only meaningful during a GC */
-bool performing_gc;
-CELL collecting_gen;
-
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
-bool collecting_aging_again;
-
-INLINE bool collecting_accumulation_gen_p(void)
-{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
- && !collecting_aging_again)
- || collecting_gen == TENURED);
-}
-
-/* What generation was being collected when collect_literals() was last
-called? Until the next call to primitive_add_compiled_block(), future
+/* What generation was being collected when copy_code_heap_roots() was last
+called? Until the next call to add_compiled_block(), future
collections of younger generations don't have to touch the code
heap. */
CELL last_code_heap_scan;
bool growing_data_heap;
F_DATA_HEAP *old_data_heap;
-/* Every object has a regular representation in the runtime, which makes GC
-much simpler. Every slot of the object until binary_payload_start is a pointer
-to some other object. */
-INLINE void do_slots(CELL obj, void (* iter)(CELL *))
+INLINE bool collecting_accumulation_gen_p(void)
{
- CELL scan = obj;
- CELL payload_start = binary_payload_start(obj);
- CELL end = obj + payload_start;
-
- scan += CELLS;
-
- while(scan < end)
- {
- iter((CELL *)scan);
- scan += CELLS;
- }
+ return ((HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ || collecting_gen == TENURED);
}
/* test if the pointer is in generation being collected, or a younger one. */
void copy_handle(CELL *handle);
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* GC is off during heap walking */
-bool gc_off;
-
void garbage_collection(volatile CELL gen,
bool growing_data_heap_,
CELL requested_bytes);
-/* If a runtime function needs to call another function which potentially
-allocates memory, it must store any local variable references to Factor
-objects on the root stack */
-
-/* GC locals: stores addresses of pointers to objects. The GC updates these
-pointers, so you can do
-
-REGISTER_ROOT(some_local);
-
-... allocate memory ...
-
-foo(some_local);
-
-...
-
-UNREGISTER_ROOT(some_local); */
-F_SEGMENT *gc_locals_region;
-CELL gc_locals;
-
-DEFPUSHPOP(gc_local_,gc_locals)
-
-#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
-#define UNREGISTER_ROOT(obj) \
- { \
- if(gc_local_pop() != (CELL)&obj) \
- critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
- }
-
-/* Extra roots: stores pointers to objects in the heap. Requires extra work
-(you have to unregister before accessing the object) but more flexible. */
-F_SEGMENT *extra_roots_region;
-CELL extra_roots;
-
-DEFPUSHPOP(root_,extra_roots)
-
-#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
-#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
-
-INLINE bool in_data_heap_p(CELL ptr)
-{
- return (ptr >= data_heap->segment->start
- && ptr <= data_heap->segment->end);
-}
-
-/* We ignore strings which point outside the data heap, but we might be given
-a char* which points inside the data heap, in which case it is a root, for
-example if we call unbox_char_string() the result is placed in a byte array */
-INLINE bool root_push_alien(const void *ptr)
-{
- if(in_data_heap_p((CELL)ptr))
- {
- F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
- if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
- {
- root_push(tag_object(objptr));
- return true;
- }
- }
-
- return false;
-}
-
-#define REGISTER_C_STRING(obj) \
- bool obj##_root = root_push_alien(obj)
-#define UNREGISTER_C_STRING(obj) \
- if(obj##_root) obj = alien_offset(root_pop())
-
-#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
-#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
-
-INLINE void *allot_zone(F_ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- return (void*)h;
-}
-
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-INLINE void* allot_object(CELL type, CELL a)
+INLINE void *allot_object(CELL type, CELL a)
{
CELL *object;
return object;
}
-void collect_next_loop(CELL scan, CELL *end);
+void copy_reachable_objects(CELL scan, CELL *end);
void primitive_gc(void);
void primitive_gc_stats(void);
-void primitive_gc_reset(void);
+void clear_gc_stats(void);
+void primitive_clear_gc_stats(void);
void primitive_become(void);
-
-CELL find_all_words(void);
--- /dev/null
+#include "master.h"
+
+CELL init_zone(F_ZONE *z, CELL size, CELL start)
+{
+ z->size = size;
+ z->start = z->here = start;
+ z->end = start + size;
+ return z->end;
+}
+
+void init_card_decks(void)
+{
+ CELL start = align(data_heap->segment->start,DECK_SIZE);
+ allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
+ cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
+ decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
+}
+
+F_DATA_HEAP *alloc_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size)
+{
+ young_size = align(young_size,DECK_SIZE);
+ aging_size = align(aging_size,DECK_SIZE);
+ tenured_size = align(tenured_size,DECK_SIZE);
+
+ F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
+ data_heap->young_size = young_size;
+ data_heap->aging_size = aging_size;
+ data_heap->tenured_size = tenured_size;
+ data_heap->gen_count = gens;
+
+ CELL total_size;
+ if(data_heap->gen_count == 2)
+ total_size = young_size + 2 * tenured_size;
+ else if(data_heap->gen_count == 3)
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
+ else
+ {
+ fatal_error("Invalid number of generations",data_heap->gen_count);
+ return NULL; /* can't happen */
+ }
+
+ total_size += DECK_SIZE;
+
+ data_heap->segment = alloc_segment(total_size);
+
+ data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+
+ CELL cards_size = total_size >> CARD_BITS;
+ data_heap->allot_markers = safe_malloc(cards_size);
+ data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
+
+ data_heap->cards = safe_malloc(cards_size);
+ data_heap->cards_end = data_heap->cards + cards_size;
+
+ CELL decks_size = total_size >> DECK_BITS;
+ data_heap->decks = safe_malloc(decks_size);
+ data_heap->decks_end = data_heap->decks + decks_size;
+
+ CELL alloter = align(data_heap->segment->start,DECK_SIZE);
+
+ alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
+
+ if(data_heap->gen_count == 3)
+ {
+ alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
+ }
+
+ if(data_heap->gen_count >= 2)
+ {
+ alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
+ }
+
+ if(data_heap->segment->end - alloter > DECK_SIZE)
+ critical_error("Bug in alloc_data_heap",alloter);
+
+ return data_heap;
+}
+
+F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
+{
+ CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
+
+ return alloc_data_heap(data_heap->gen_count,
+ data_heap->young_size,
+ data_heap->aging_size,
+ new_tenured_size);
+}
+
+void dealloc_data_heap(F_DATA_HEAP *data_heap)
+{
+ dealloc_segment(data_heap->segment);
+ free(data_heap->generations);
+ free(data_heap->semispaces);
+ free(data_heap->allot_markers);
+ free(data_heap->cards);
+ free(data_heap->decks);
+ free(data_heap);
+}
+
+void clear_cards(CELL from, CELL to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
+ F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
+ memset(first_card,0,last_card - first_card);
+}
+
+void clear_decks(CELL from, CELL to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
+ F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
+ memset(first_deck,0,last_deck - first_deck);
+}
+
+void clear_allot_markers(CELL from, CELL to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
+ F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
+ memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+}
+
+void reset_generation(CELL i)
+{
+ F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
+
+ z->here = z->start;
+ if(secure_gc)
+ memset((void*)z->start,69,z->size);
+}
+
+/* After garbage collection, any generations which are now empty need to have
+their allocation pointers and cards reset. */
+void reset_generations(CELL from, CELL to)
+{
+ CELL i;
+ for(i = from; i <= to; i++)
+ reset_generation(i);
+
+ clear_cards(from,to);
+ clear_decks(from,to);
+ clear_allot_markers(from,to);
+}
+
+void set_data_heap(F_DATA_HEAP *data_heap_)
+{
+ data_heap = data_heap_;
+ nursery = data_heap->generations[NURSERY];
+ init_card_decks();
+ clear_cards(NURSERY,TENURED);
+ clear_decks(NURSERY,TENURED);
+ clear_allot_markers(NURSERY,TENURED);
+}
+
+void init_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size,
+ bool secure_gc_)
+{
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
+
+ gc_locals_region = alloc_segment(getpagesize());
+ gc_locals = gc_locals_region->start - CELLS;
+
+ extra_roots_region = alloc_segment(getpagesize());
+ extra_roots = extra_roots_region->start - CELLS;
+
+ secure_gc = secure_gc_;
+}
+
+/* Size of the object pointed to by a tagged pointer */
+CELL object_size(CELL tagged)
+{
+ if(immediate_p(tagged))
+ return 0;
+ else
+ return untagged_object_size(UNTAG(tagged));
+}
+
+/* Size of the object pointed to by an untagged pointer */
+CELL untagged_object_size(CELL pointer)
+{
+ return align8(unaligned_object_size(pointer));
+}
+
+/* Size of the data area of an object pointed to by an untagged pointer */
+CELL unaligned_object_size(CELL pointer)
+{
+ F_TUPLE *tuple;
+ F_TUPLE_LAYOUT *layout;
+
+ switch(untag_header(get(pointer)))
+ {
+ case ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ return array_size(array_capacity((F_ARRAY*)pointer));
+ case BYTE_ARRAY_TYPE:
+ return byte_array_size(
+ byte_array_capacity((F_BYTE_ARRAY*)pointer));
+ case STRING_TYPE:
+ return string_size(string_capacity((F_STRING*)pointer));
+ case TUPLE_TYPE:
+ tuple = untag_object(pointer);
+ layout = untag_object(tuple->layout);
+ return tuple_size(layout);
+ case QUOTATION_TYPE:
+ return sizeof(F_QUOTATION);
+ case WORD_TYPE:
+ return sizeof(F_WORD);
+ case RATIO_TYPE:
+ return sizeof(F_RATIO);
+ case FLOAT_TYPE:
+ return sizeof(F_FLOAT);
+ case COMPLEX_TYPE:
+ return sizeof(F_COMPLEX);
+ case DLL_TYPE:
+ return sizeof(F_DLL);
+ case ALIEN_TYPE:
+ return sizeof(F_ALIEN);
+ case WRAPPER_TYPE:
+ return sizeof(F_WRAPPER);
+ case CALLSTACK_TYPE:
+ return callstack_size(
+ untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
+ default:
+ critical_error("Invalid header",pointer);
+ return -1; /* can't happen */
+ }
+}
+
+void primitive_size(void)
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
+/* The number of cells from the start of the object which should be scanned by
+the GC. Some types have a binary payload at the end (string, word, DLL) which
+we ignore. */
+CELL binary_payload_start(CELL pointer)
+{
+ F_TUPLE *tuple;
+ F_TUPLE_LAYOUT *layout;
+
+ switch(untag_header(get(pointer)))
+ {
+ /* these objects do not refer to other objects at all */
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ case CALLSTACK_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(F_WORD) - CELLS * 3;
+ case ALIEN_TYPE:
+ return CELLS * 3;
+ case DLL_TYPE:
+ return CELLS * 2;
+ case QUOTATION_TYPE:
+ return sizeof(F_QUOTATION) - CELLS * 2;
+ case STRING_TYPE:
+ return sizeof(F_STRING);
+ /* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size(array_capacity((F_ARRAY*)pointer));
+ case TUPLE_TYPE:
+ tuple = untag_object(pointer);
+ layout = untag_object(tuple->layout);
+ return tuple_size(layout);
+ case RATIO_TYPE:
+ return sizeof(F_RATIO);
+ case COMPLEX_TYPE:
+ return sizeof(F_COMPLEX);
+ case WRAPPER_TYPE:
+ return sizeof(F_WRAPPER);
+ default:
+ critical_error("Invalid header",pointer);
+ return -1; /* can't happen */
+ }
+}
+
+/* Push memory usage statistics in data heap */
+void primitive_data_room(void)
+{
+ F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
+ int gen;
+
+ dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
+ dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
+
+ for(gen = 0; gen < data_heap->gen_count; gen++)
+ {
+ F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
+ set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
+ set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
+ }
+
+ dpush(tag_object(a));
+}
+
+/* Disables GC and activates next-object ( -- obj ) primitive */
+void begin_scan(void)
+{
+ heap_scan_ptr = data_heap->generations[TENURED].start;
+ gc_off = true;
+}
+
+void primitive_begin_scan(void)
+{
+ begin_scan();
+}
+
+CELL next_object(void)
+{
+ if(!gc_off)
+ general_error(ERROR_HEAP_SCAN,F,F,NULL);
+
+ CELL value = get(heap_scan_ptr);
+ CELL obj = heap_scan_ptr;
+ CELL type;
+
+ if(heap_scan_ptr >= data_heap->generations[TENURED].here)
+ return F;
+
+ type = untag_header(value);
+ heap_scan_ptr += untagged_object_size(heap_scan_ptr);
+
+ return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
+}
+
+/* Push object at heap scan cursor and advance; pushes f when done */
+void primitive_next_object(void)
+{
+ dpush(next_object());
+}
+
+/* Re-enables GC */
+void primitive_end_scan(void)
+{
+ gc_off = false;
+}
+
+CELL find_all_words(void)
+{
+ GROWABLE_ARRAY(words);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ GROWABLE_ARRAY_ADD(words,obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ GROWABLE_ARRAY_TRIM(words);
+
+ return words;
+}
--- /dev/null
+/* Set by the -securegc command line argument */
+bool secure_gc;
+
+/* generational copying GC divides memory into zones */
+typedef struct {
+ /* allocation pointer is 'here'; its offset is hardcoded in the
+ compiler backends*/
+ CELL start;
+ CELL here;
+ CELL size;
+ CELL end;
+} F_ZONE;
+
+typedef struct {
+ F_SEGMENT *segment;
+
+ CELL young_size;
+ CELL aging_size;
+ CELL tenured_size;
+
+ CELL gen_count;
+
+ F_ZONE *generations;
+ F_ZONE* semispaces;
+
+ CELL *allot_markers;
+ CELL *allot_markers_end;
+
+ CELL *cards;
+ CELL *cards_end;
+
+ CELL *decks;
+ CELL *decks_end;
+} F_DATA_HEAP;
+
+F_DATA_HEAP *data_heap;
+
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+#define HAVE_NURSERY_P (data_heap->gen_count>1)
+/* where objects hang around */
+#define AGING (data_heap->gen_count-2)
+#define HAVE_AGING_P (data_heap->gen_count>2)
+/* the oldest generation */
+#define TENURED (data_heap->gen_count-1)
+
+#define MIN_GEN_COUNT 1
+#define MAX_GEN_COUNT 3
+
+/* new objects are allocated here */
+DLLEXPORT F_ZONE nursery;
+
+INLINE bool in_zone(F_ZONE *z, CELL pointer)
+{
+ return pointer >= z->start && pointer < z->end;
+}
+
+CELL init_zone(F_ZONE *z, CELL size, CELL base);
+
+void init_card_decks(void);
+
+F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
+
+void dealloc_data_heap(F_DATA_HEAP *data_heap);
+
+void clear_cards(CELL from, CELL to);
+void clear_decks(CELL from, CELL to);
+void clear_allot_markers(CELL from, CELL to);
+void reset_generation(CELL i);
+void reset_generations(CELL from, CELL to);
+
+void set_data_heap(F_DATA_HEAP *data_heap_);
+
+void init_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size,
+ bool secure_gc_);
+
+/* set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
+F_SEGMENT *alloc_segment(CELL size);
+void dealloc_segment(F_SEGMENT *block);
+
+CELL untagged_object_size(CELL pointer);
+CELL unaligned_object_size(CELL pointer);
+CELL object_size(CELL pointer);
+CELL binary_payload_start(CELL pointer);
+
+void begin_scan(void);
+CELL next_object(void);
+
+void primitive_data_room(void);
+void primitive_size(void);
+
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* GC is off during heap walking */
+bool gc_off;
+
+INLINE bool in_data_heap_p(CELL ptr)
+{
+ return (ptr >= data_heap->segment->start
+ && ptr <= data_heap->segment->end);
+}
+
+INLINE void *allot_zone(F_ZONE *z, CELL a)
+{
+ CELL h = z->here;
+ z->here = h + align8(a);
+ return (void*)h;
+}
+
+CELL find_all_words(void);
+
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+INLINE void do_slots(CELL obj, void (* iter)(CELL *))
+{
+ CELL scan = obj;
+ CELL payload_start = binary_payload_start(obj);
+ CELL end = obj + payload_start;
+
+ scan += CELLS;
+
+ while(scan < end)
+ {
+ iter((CELL *)scan);
+ scan += CELLS;
+ }
+}
gc_off = false;
}
-CELL look_for;
-
-void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
+/* Dump all code blocks for debugging */
+void dump_code_heap(void)
{
- CELL scan;
- CELL literal_end = literals_start + compiled->literals_length;
-
- for(scan = literals_start; scan < literal_end; scan += CELLS)
- {
- CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start + compiled->code_length;
+ CELL size = 0;
- CELL obj = get(literal_start);
+ F_BLOCK *scan = first_block(&code_heap);
- if(look_for == get(scan))
+ while(scan)
+ {
+ char *status;
+ switch(scan->status)
{
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
+ case B_FREE:
+ status = "free";
+ break;
+ case B_ALLOCATED:
+ size += object_size(block_to_compiled(scan)->relocation);
+ status = "allocated";
+ break;
+ case B_MARKED:
+ size += object_size(block_to_compiled(scan)->relocation);
+ status = "marked";
+ break;
+ default:
+ status = "invalid";
+ break;
}
- }
-}
-void find_code_references(CELL look_for_)
-{
- look_for = look_for_;
- iterate_code_heap(find_code_references_step);
+ print_cell_hex((CELL)scan); print_string(" ");
+ print_cell_hex(scan->size); print_string(" ");
+ print_string(status); print_string("\n");
+
+ scan = next_block(&code_heap,scan);
+ }
+
+ print_cell(size); print_string(" bytes of relocation data\n");
}
void factorbug(void)
CELL addr = read_cell_hex();
print_string("Data heap references:\n");
find_data_references(addr);
- print_string("Code heap references:\n");
- find_code_references(addr);
nl();
}
else if(strcmp(cmd,"words") == 0)
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
- dump_heap(&code_heap);
+ dump_code_heap();
else
print_string("unknown command\n");
}
p->tenured_size,
p->secure_gc);
+ clear_gc_stats();
+
F_ZONE *tenured = &data_heap->generations[TENURED];
F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
}
}
-void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
+void fixup_code_block(F_CODE_BLOCK *compiled)
{
/* relocate literal table data */
- CELL scan;
- CELL literal_end = literals_start + compiled->literals_length;
-
data_fixup(&compiled->relocation);
+ data_fixup(&compiled->literals);
- for(scan = literals_start; scan < literal_end; scan += CELLS)
- data_fixup((CELL*)scan);
-
- relocate_code_block(compiled,code_start,literals_start);
+ relocate_code_block(compiled);
}
void relocate_code()
{
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
+ char needs_fixup; /* is this a new block that needs full fixup? */
CELL code_length; /* # bytes */
- CELL literals_length; /* # bytes */
+ CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
-} F_COMPILED;
+} F_CODE_BLOCK;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL def;
/* TAGGED property assoc for library code */
CELL props;
- /* TAGGED t or f, depending on if the word is compiled or not */
- CELL compiledp;
+ /* TAGGED t or f, t means its compiled with the optimizing compiler,
+ f means its compiled with the non-optimizing compiler */
+ CELL optimizedp;
/* TAGGED call count for profiling */
CELL counter;
/* TAGGED machine code for sub-primitive */
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
- F_COMPILED *code;
+ F_CODE_BLOCK *code;
/* UNTAGGED profiler stub */
- F_COMPILED *profiling;
+ F_CODE_BLOCK *profiling;
} F_WORD;
/* Assembly code makes assumptions about the layout of this struct */
/* UNTAGGED */
XT xt;
/* UNTAGGED compiled code block */
- F_COMPILED *code;
+ F_CODE_BLOCK *code;
} F_QUOTATION;
/* Assembly code makes assumptions about the layout of this struct */
--- /dev/null
+/* If a runtime function needs to call another function which potentially
+allocates memory, it must store any local variable references to Factor
+objects on the root stack */
+
+/* GC locals: stores addresses of pointers to objects. The GC updates these
+pointers, so you can do
+
+REGISTER_ROOT(some_local);
+
+... allocate memory ...
+
+foo(some_local);
+
+...
+
+UNREGISTER_ROOT(some_local); */
+F_SEGMENT *gc_locals_region;
+CELL gc_locals;
+
+DEFPUSHPOP(gc_local_,gc_locals)
+
+#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
+#define UNREGISTER_ROOT(obj) \
+ { \
+ if(gc_local_pop() != (CELL)&obj) \
+ critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
+ }
+
+/* Extra roots: stores pointers to objects in the heap. Requires extra work
+(you have to unregister before accessing the object) but more flexible. */
+F_SEGMENT *extra_roots_region;
+CELL extra_roots;
+
+DEFPUSHPOP(root_,extra_roots)
+
+#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
+#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
+
+/* We ignore strings which point outside the data heap, but we might be given
+a char* which points inside the data heap, in which case it is a root, for
+example if we call unbox_char_string() the result is placed in a byte array */
+INLINE bool root_push_alien(const void *ptr)
+{
+ if(in_data_heap_p((CELL)ptr))
+ {
+ F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
+ if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
+ {
+ root_push(tag_object(objptr));
+ return true;
+ }
+ }
+
+ return false;
+}
+
+#define REGISTER_C_STRING(obj) \
+ bool obj##_root = root_push_alien(obj)
+#define UNREGISTER_C_STRING(obj) \
+ if(obj##_root) obj = alien_offset(root_pop())
+
+#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
+#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
+#include "write_barrier.h"
+#include "data_heap.h"
+#include "local_roots.h"
#include "data_gc.h"
#include "debug.h"
#include "types.h"
#include "float_bits.h"
#include "io.h"
#include "code_gc.h"
+#include "code_block.h"
#include "code_heap.h"
#include "image.h"
#include "callstack.h"
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
- primitive_gc_reset,
+ primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
};
#include "master.h"
/* Allocates memory */
-F_COMPILED *compile_profiling_stub(F_WORD *word)
+F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
{
CELL literals = allot_array_1(tag_object(word));
REGISTER_ROOT(literals);
untag_object(code),
NULL, /* no labels */
tag_object(relocation),
- untag_object(literals));
+ literals);
}
/* Allocates memory */
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
- F_COMPILED *profiling = compile_profiling_stub(word);
+ F_CODE_BLOCK *profiling = compile_profiling_stub(word);
UNREGISTER_UNTAGGED(word);
word->profiling = profiling;
}
bool profiling_p;
void primitive_profiling(void);
-F_COMPILED *compile_profiling_stub(F_WORD *word);
+F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);
return false;
}
-void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
+void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("bad param to set_quot_xt",(CELL)code);
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
- F_COMPILED *compiled = add_compiled_block(
+ F_CODE_BLOCK *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
relocation,
- untag_object(literals));
+ literals);
set_quot_xt(untag_object(quot),compiled);
if(relocate)
- iterate_code_heap_step(compiled,relocate_code_block);
+ relocate_code_block(compiled);
UNREGISTER_ROOT(literals);
UNREGISTER_ROOT(relocation);
{
F_WORD *word = untag_word(array_nth(untag_array(words),i));
REGISTER_UNTAGGED(word);
- if(word->compiledp == F)
+ if(word->optimizedp == F)
default_word_code(word,false);
UNREGISTER_UNTAGGED(word);
update_word_xt(word);
-void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
+void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
- word->compiledp = F;
+ word->optimizedp = F;
word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;
UNREGISTER_UNTAGGED(word);
if(profiling_p)
- iterate_code_heap_step(word->profiling,relocate_code_block);
+ relocate_code_block(word->profiling);
return word;
}
void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
- F_COMPILED *code = (profiling_p ? word->profiling : word->code);
- dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
- dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
+ F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
+ dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
+ dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK) + code->code_length));
}
void primitive_wrapper(void)
--- /dev/null
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator. */
+
+/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
+#define CARD_POINTS_TO_NURSERY 0x80
+#define CARD_POINTS_TO_AGING 0x40
+#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+typedef u8 F_CARD;
+
+#define CARD_BITS 8
+#define CARD_SIZE (1<<CARD_BITS)
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+DLLEXPORT CELL cards_offset;
+
+#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
+#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
+
+typedef u8 F_DECK;
+
+#define DECK_BITS (CARD_BITS + 10)
+#define DECK_SIZE (1<<DECK_BITS)
+#define ADDR_DECK_MASK (DECK_SIZE-1)
+
+DLLEXPORT CELL decks_offset;
+
+#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
+#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
+
+#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
+
+#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
+#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+
+#define INVALID_ALLOT_MARKER 0xff
+
+DLLEXPORT CELL allot_markers_offset;
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+INLINE void write_barrier(CELL address)
+{
+ *ADDR_TO_CARD(address) = CARD_MARK_MASK;
+ *ADDR_TO_DECK(address) = CARD_MARK_MASK;
+}
+
+#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
+
+INLINE void set_slot(CELL obj, CELL slot, CELL value)
+{
+ put(SLOT(obj,slot),value);
+ write_barrier(obj);
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+ F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
+ if(*ptr == INVALID_ALLOT_MARKER)
+ *ptr = (address & ADDR_CARD_MASK);
+}
projects / factor.git / commitdiff