diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 1ff04bacc2..aa7377adbf 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -482,8 +482,6 @@ PRIVATE> : make-image ( arch -- ) [ architecture set - bootstrapping? on - load-help? off "resource:/core/bootstrap/stage1.factor" run-file build-image write-image diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3ce783d620..31ba4e4b6d 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -51,6 +51,8 @@ call ! After we execute bootstrap/layouts num-types get f builtins set +bootstrapping? on + ! Create some empty vocabs where the below primitives and ! classes will go { diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index f99c8eb82f..64402ca2e1 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -13,6 +13,8 @@ vocabs.loader system debugger continuations ; "resource:core/bootstrap/primitives.factor" run-file +load-help? off + ! Create a boot quotation for the target [ [ diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 9594cf7b23..8610f490ec 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -4,8 +4,8 @@ USING: math kernel layouts system ; IN: compiler.constants ! These constants must match vm/memory.h -: card-bits 6 ; -: deck-bits 12 ; +: card-bits 8 ; +: deck-bits 18 ; : card-mark HEX: 40 HEX: 80 bitor ; ! These constants must match vm/layouts.h diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index d85c70577e..1b28f7262e 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -18,13 +18,13 @@ IN: cpu.ppc.intrinsics "obj" get operand-tag - ; : %slot-literal-any-tag - "obj" operand "scratch" operand %untag - "val" operand "scratch" operand "n" get cells ; + "obj" operand "scratch1" operand %untag + "val" operand "scratch1" operand "n" get cells ; : %slot-any - "obj" operand "scratch" operand %untag + "obj" operand "scratch1" operand %untag "offset" operand "n" operand 1 SRAWI - "scratch" operand "val" operand "offset" operand ; + "scratch1" operand "val" operand "offset" operand ; \ slot { ! Slot number is literal and the tag is known @@ -39,7 +39,7 @@ IN: cpu.ppc.intrinsics { [ %slot-literal-any-tag LWZ ] H{ { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } { f "val" } } } + { +scratch+ { { f "scratch1" } { f "val" } } } { +output+ { "val" } } } } @@ -47,7 +47,7 @@ IN: cpu.ppc.intrinsics { [ %slot-any LWZX ] H{ { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } } + { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } } { +output+ { "val" } } } } @@ -61,17 +61,17 @@ IN: cpu.ppc.intrinsics : %write-barrier ( -- ) "val" get operand-immediate? "obj" get fresh-object? or [ - "scratch1" operand card-mark LI + card-mark "scratch1" operand LI ! Mark the card "val" operand load-cards-offset "obj" operand "scratch2" operand card-bits SRWI - "val" operand "scratch2" operand "val" operand STBX + "scratch2" operand "scratch1" operand "val" operand STBX ! Mark the card deck "val" operand load-decks-offset - "obj" operand "scratch" operand deck-bits SRWI - "val" operand "scratch" operand "val" operand STBX + "obj" operand "scratch2" operand deck-bits SRWI + "scratch2" operand "scratch1" operand "val" operand STBX ] unless ; \ set-slot { @@ -87,7 +87,7 @@ IN: cpu.ppc.intrinsics { [ %slot-literal-any-tag STW %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } } } + { +scratch+ { { f "scratch1" } { f "scratch2" } } } { +clobber+ { "val" } } } } @@ -95,7 +95,7 @@ IN: cpu.ppc.intrinsics { [ %slot-any STWX %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { f "n" } } } - { +scratch+ { { f "scratch" } { f "offset" } } } + { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } } { +clobber+ { "val" } } } } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index a463fd2e40..84b0bd3e09 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ IN: io.files.tests USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences -strings accessors io.encodings.utf8 ; +strings accessors io.encodings.utf8 math ; [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test @@ -43,6 +43,8 @@ strings accessors io.encodings.utf8 ; "file4" temp-file delete-file ] unit-test +[ "file5" temp-file delete-file ] ignore-errors + [ ] [ temp-directory [ "file5" touch-file @@ -50,6 +52,8 @@ strings accessors io.encodings.utf8 ; ] with-directory ] unit-test +[ "file6" temp-file delete-file ] ignore-errors + [ ] [ temp-directory [ "file6" touch-file @@ -259,3 +263,6 @@ strings accessors io.encodings.utf8 ; [ t ] [ "resource:core" absolute-path? ] unit-test [ f ] [ "" absolute-path? ] unit-test + +[ "touch-twice-test" temp-file delete-file ] ignore-errors +[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index d43599776b..bcad667c60 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces sequences sbufs strings generic splitting growable continuations io.streams.plain -io.encodings io.encodings.private math.order ; +io.encodings math.order ; IN: io.streams.string M: growable dispose drop ; @@ -77,6 +77,3 @@ M: plain-writer stream-write-table [ drop format-table [ print ] each ] with-output-stream* ; M: plain-writer make-cell-stream 2drop ; - -M: growable stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 0e33ccd94c..122b7f1d59 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -4,7 +4,7 @@ words ; IN: threads.tests 3 "x" set -namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop +[ 2 "x" set ] "Test" spawn drop [ 2 ] [ yield "x" get ] unit-test [ ] [ [ flush ] "flush test" spawn drop flush ] unit-test [ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 138b1ef928..b640cc6384 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -136,9 +136,9 @@ SYMBOL: visited [ reset-on-redefine reset-props ] [ dup visited get set-at ] [ - crossref get at keys [ word? ] filter [ - reset-on-redefine [ word-prop ] with contains? - ] filter + crossref get at keys + [ word? ] filter + [ reset-on-redefine [ word-prop ] with contains? ] filter [ (redefined) ] each ] tri ] if ; diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor index 101d259f7c..2ac8482a76 100644 --- a/extra/builder/report/report.factor +++ b/extra/builder/report/report.factor @@ -15,8 +15,8 @@ IN: builder.report "Build directory: " write build-dir print "git id: " write "git-id" eval-file print nl - status-vm get f = [ "compile-log" cat "vm compile error" throw ] when - status-boot get f = [ "boot-log" cat "Boot error" throw ] when + status-vm get f = [ "compile-log" cat "vm compile error" throw ] when + status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when "Boot time: " write "boot-time" eval-file milli-seconds>time print diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index 5f9f1e41ac..1e83c15694 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -16,12 +16,12 @@ PROTOCOL: assoc-protocol assoc-like ; PROTOCOL: input-stream-protocol - stream-read1 stream-read stream-read-until - stream-read-quot ; + stream-read1 stream-read stream-read-partial stream-readln + stream-read-until stream-read-quot ; PROTOCOL: output-stream-protocol stream-flush stream-write1 stream-write stream-format - stream-nl make-span-stream make-block-stream stream-readln + stream-nl make-span-stream make-block-stream make-cell-stream stream-write-table ; PROTOCOL: definition-protocol diff --git a/extra/io/streams/duplex/duplex-tests.factor b/extra/io/streams/duplex/duplex-tests.factor index ebc6b3be1f..9377256c0d 100755 --- a/extra/io/streams/duplex/duplex-tests.factor +++ b/extra/io/streams/duplex/duplex-tests.factor @@ -1,4 +1,5 @@ -USING: io.streams.duplex io kernel continuations tools.test ; +USING: io.streams.duplex io io.streams.string +kernel continuations tools.test ; IN: io.streams.duplex.tests ! Test duplex stream close behavior @@ -38,3 +39,8 @@ M: unclosable-stream dispose [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test + +[ "Hey" ] [ + "Hey\nThere" + stream-readln +] unit-test diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 08ff526f14..902af8fe0d 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix +io.nonblocking sequences strings structs sbufs threads unix.ffi unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces io.timeouts io.encodings.utf8 accessors ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index b361974a20..28e08d4bf2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -45,10 +45,9 @@ M: unix (file-appender) ( path -- stream ) M: unix touch-file ( path -- ) normalize-path - dup exists? - [ f utime ] - [ touch-mode file-mode open close ] - if ; + dup exists? [ f utime ] [ + touch-mode file-mode open close + ] if ; M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100644 new mode 100755 index 8e8fb0ec74..ec82a426d3 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math math.bitfields namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets -unix unix.time unix.kqueue unix.process +unix.ffi unix unix.time unix.kqueue unix.process io.nonblocking io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index b60cb5760e..71edbc5500 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -5,7 +5,7 @@ namespaces threads sequences byte-arrays io.nonblocking io.binary io.unix.backend io.streams.duplex io.sockets.impl io.backend io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors -qualified unix ; +qualified unix.ffi unix ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 85c5a8dbaf..58e2b1f882 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types colors jamshred.game jamshred.oint +USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.vectors opengl opengl.gl opengl.glu sequences ; IN: jamshred.gl @@ -37,10 +37,6 @@ IN: jamshred.gl : draw-tunnel ( player -- ) segments-to-render draw-segments ; -! : draw-tunnel ( player tunnel -- ) -! tuck swap player-nearest-segment segment-number dup n-segments-behind - -! swap n-segments-ahead + rot sub-tunnel draw-segments ; - : init-graphics ( width height -- ) GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable @@ -63,9 +59,9 @@ IN: jamshred.gl GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; : player-view ( player -- ) - [ oint-location first3 ] keep - [ dup oint-location swap oint-forward v+ first3 ] keep - oint-up first3 gluLookAt ; + [ location>> first3 ] + [ [ location>> ] [ forward>> ] bi v+ first3 ] + [ up>> first3 ] tri gluLookAt ; : draw-jamshred ( jamshred width height -- ) init-graphics jamshred-player dup player-view draw-tunnel ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 139cdbfb53..f3fa9a0354 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -127,7 +127,9 @@ C: segment [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; : collision-vector ( oint segment -- v ) - [ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri + [ sideways-heading ] [ sideways-relative-location ] + [ radius>> 0.1 - ] ! bounce before we hit so that we can't see through the wall (hack?) + 2tri swap [ collision-coefficient ] dip forward>> n*v ; : distance-to-collision ( oint segment -- distance ) diff --git a/extra/lisp/authors.txt b/extra/lisp/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor new file mode 100644 index 0000000000..ec376569f0 --- /dev/null +++ b/extra/lisp/lisp-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: lisp lisp.parser tools.test sequences math kernel ; + +IN: lisp.test + +{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [ + "(foo 1 2 \"aoeu\")" lisp-string>factor +] unit-test + +init-env + +"+" [ first2 + ] lisp-define + +{ [ first2 + ] } [ + "+" lisp-get +] unit-test + +{ 3 } [ + "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call +] unit-test \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor new file mode 100644 index 0000000000..7d4b9af02a --- /dev/null +++ b/extra/lisp/lisp.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel peg sequences arrays strings combinators.lib +namespaces combinators math bake locals locals.private accessors +vectors syntax lisp.parser assocs parser sequences.lib ; +IN: lisp + +DEFER: convert-form +DEFER: funcall + +! Functions to convert s-exps to quotations +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: convert-body ( s-exp -- quot ) + [ convert-form ] map [ ] [ compose ] reduce ; inline + +: convert-if ( s-exp -- quot ) + rest [ convert-form ] map reverse first3 [ % , , if ] bake ; + +: convert-begin ( s-exp -- quot ) + rest convert-form ; + +: convert-cond ( s-exp -- quot ) + rest [ [ convert-form map ] map ] [ % cond ] bake ; + +: convert-general-form ( s-exp -- quot ) + unclip convert-form swap convert-body [ , % funcall ] bake ; + +> swap member? [ name>> make-local ] [ ] if ] + [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if + ] with map ; + +: localize-lambda ( body vars -- newbody newvars ) + dup make-locals dup push-locals [ swap localize-body convert-form ] dipd + pop-locals swap ; + +PRIVATE> + +: split-lambda ( s-exp -- body vars ) + first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline + +: rest-lambda-vars ( seq -- n newseq ) + "&rest" swap [ remove ] [ index ] 2bi ; + +: convert-lambda ( s-exp -- quot ) + split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if + [ localize-lambda ] dip + [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ; + +: convert-quoted ( s-exp -- quot ) + second [ , ] bake ; + +: convert-list-form ( s-exp -- quot ) + dup first dup lisp-symbol? + [ name>> + { { "lambda" [ convert-lambda ] } + { "quote" [ convert-quoted ] } + { "if" [ convert-if ] } + { "begin" [ convert-begin ] } + { "cond" [ convert-cond ] } + [ drop convert-general-form ] + } case ] + [ drop convert-general-form ] if ; + +: convert-form ( lisp-form -- quot ) + { { [ dup s-exp? ] [ body>> convert-list-form ] } + [ [ , ] [ ] make ] + } cond ; + +: lisp-string>factor ( str -- quot ) + lisp-expr parse-result-ast convert-form ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: lisp-env + +: init-env ( -- ) + H{ } clone lisp-env set ; + +: lisp-define ( name quot -- ) + swap lisp-env get set-at ; + +: lisp-get ( name -- word ) + lisp-env get at ; + +: funcall ( quot sym -- * ) + dup lisp-symbol? [ name>> lisp-get ] when call ; inline \ No newline at end of file diff --git a/extra/lisp/parser/authors.txt b/extra/lisp/parser/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/parser/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor new file mode 100644 index 0000000000..9e6b54ab0c --- /dev/null +++ b/extra/lisp/parser/parser-tests.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: lisp.parser tools.test peg peg.ebnf ; + +IN: lisp.parser.tests + +{ 1234 } [ + "1234" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ 123.98 } [ + "123.98" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ "" } [ + "\"\"" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ "aoeu" } [ + "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ "aoeu\"de" } [ + "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ T{ lisp-symbol f "foobar" } } [ + "foobar" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ T{ lisp-symbol f "+" } } [ + "+" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ T{ s-exp f + V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [ + "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +] unit-test \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor new file mode 100644 index 0000000000..65ad01aa6f --- /dev/null +++ b/extra/lisp/parser/parser.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings +combinators.lib ; + +IN: lisp.parser + +TUPLE: lisp-symbol name ; +C: lisp-symbol + +TUPLE: s-exp body ; +C: s-exp + +EBNF: lisp-expr +_ = (" " | "\t" | "\n")* +LPAREN = "(" +RPAREN = ")" +dquote = '"' +squote = "'" +digit = [0-9] +integer = (digit)+ => [[ string>number ]] +float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]] +number = float + | integer +id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" + | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" +letters = [a-zA-Z] => [[ 1array >string ]] +initials = letters | id-specials +numbers = [0-9] => [[ 1array >string ]] +subsequents = initials | numbers +identifier = initials (subsequents)* => [[ first2 concat append ]] +escaped = "\" . => [[ second ]] +string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] +atom = number + | identifier + | string +list-item = _ (atom|s-expression) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second ]] +;EBNF \ No newline at end of file diff --git a/extra/lisp/parser/summary.txt b/extra/lisp/parser/summary.txt new file mode 100644 index 0000000000..aa407b3dfb --- /dev/null +++ b/extra/lisp/parser/summary.txt @@ -0,0 +1 @@ +EBNF grammar for parsing Lisp diff --git a/extra/lisp/parser/tags.txt b/extra/lisp/parser/tags.txt new file mode 100644 index 0000000000..d1f6fa1ef3 --- /dev/null +++ b/extra/lisp/parser/tags.txt @@ -0,0 +1,2 @@ +lisp +parsing diff --git a/extra/lisp/summary.txt b/extra/lisp/summary.txt new file mode 100644 index 0000000000..8c36217f1c --- /dev/null +++ b/extra/lisp/summary.txt @@ -0,0 +1 @@ +A Lisp interpreter in Factor diff --git a/extra/lisp/tags.txt b/extra/lisp/tags.txt new file mode 100644 index 0000000000..c369ccae57 --- /dev/null +++ b/extra/lisp/tags.txt @@ -0,0 +1,2 @@ +lisp +languages diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index c668806fc2..f1953340db 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -3,21 +3,9 @@ math.functions math.ranges namespaces random sequences hashtables sets ; IN: math.miller-rabin -SYMBOL: a -SYMBOL: n -SYMBOL: r -SYMBOL: s -SYMBOL: count -SYMBOL: trials - -: >even ( n -- int ) - dup even? [ 1- ] unless ; foldable - -: >odd ( n -- int ) - dup even? [ 1+ ] when ; foldable - -: next-odd ( m -- n ) - dup even? [ 1+ ] [ 2 + ] if ; +: >even ( n -- int ) dup even? [ 1- ] unless ; foldable +: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable +: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; TUPLE: positive-even-expected n ; @@ -28,34 +16,30 @@ TUPLE: positive-even-expected n ; #! factor an integer into s * 2^r 0 swap (factor-2s) ; -:: (miller-rabin) ( n prime?! -- ? ) - n 1- factor-2s s set r set - trials get [ - n 1- [1,b] random a set - a get s get n ^mod 1 = [ - 0 count set - r get [ - 2^ s get * a get swap n ^mod n - -1 = [ - count [ 1+ ] change - r get + - ] when - ] each - count get zero? [ - f prime?! - trials get + - ] when - ] unless - drop - ] each prime? ; - -TUPLE: miller-rabin-bounds ; +:: (miller-rabin) ( n trials -- ? ) + [let | r [ n 1- factor-2s drop ] + s [ n 1- factor-2s nip ] + prime?! [ t ] + a! [ 0 ] + count! [ 0 ] | + trials [ + n 1- [1,b] random a! + a s n ^mod 1 = [ + 0 count! + r [ + 2^ s * a swap n ^mod n - -1 = + [ count 1+ count! r + ] when + ] each + count zero? [ f prime?! trials + ] when + ] unless drop + ] each prime? ] ; : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } { [ dup 2 = ] [ 3drop t ] } { [ dup even? ] [ 3drop f ] } - [ [ drop trials set t (miller-rabin) ] with-scope ] + [ [ drop (miller-rabin) ] with-scope ] } cond ; : miller-rabin ( n -- ? ) 10 miller-rabin* ; @@ -66,7 +50,11 @@ TUPLE: miller-rabin-bounds ; : random-prime ( numbits -- p ) random-bits next-prime ; +ERROR: no-relative-prime n ; + : (find-relative-prime) ( n guess -- p ) + over 1 <= [ over no-relative-prime ] when + dup 1 <= [ drop 3 ] when 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ; : find-relative-prime* ( n guess -- p ) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 162512f9f3..5d350d80c4 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -68,7 +68,9 @@ IN: smtp.tests rot from>> ] unit-test -[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test +[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test + +[ ] [ yield ] unit-test [ ] [ [ @@ -85,3 +87,5 @@ IN: smtp.tests send-email ] with-scope ] unit-test + +[ ] [ yield ] unit-test diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index b5d01b6ed2..644cf9aa72 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,99 +1,92 @@ USING: combinators io io.files io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences -strings system hexdump io.encodings.binary inspector accessors ; +strings system hexdump io.encodings.binary inspector accessors +io.backend symbols byte-arrays ; IN: tar -: zero-checksum 256 ; +: zero-checksum 256 ; inline +: block-size 512 ; inline TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; +ERROR: checksum-error ; -: ( -- obj ) tar-header new ; +SYMBOLS: base-dir filename ; -: tar-trim ( seq -- newseq ) - [ "\0 " member? ] trim ; +: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; : read-tar-header ( -- obj ) - - 100 read-c-string* over set-tar-header-name - 8 read-c-string* tar-trim oct> over set-tar-header-mode - 8 read-c-string* tar-trim oct> over set-tar-header-uid - 8 read-c-string* tar-trim oct> over set-tar-header-gid - 12 read-c-string* tar-trim oct> over set-tar-header-size - 12 read-c-string* tar-trim oct> over set-tar-header-mtime - 8 read-c-string* tar-trim oct> over set-tar-header-checksum - read1 over set-tar-header-typeflag - 100 read-c-string* over set-tar-header-linkname - 6 read over set-tar-header-magic - 2 read over set-tar-header-version - 32 read-c-string* over set-tar-header-uname - 32 read-c-string* over set-tar-header-gname - 8 read tar-trim oct> over set-tar-header-devmajor - 8 read tar-trim oct> over set-tar-header-devminor - 155 read-c-string* over set-tar-header-prefix ; + \ tar-header new + 100 read-c-string* >>name + 8 read-c-string* tar-trim oct> >>mode + 8 read-c-string* tar-trim oct> >>uid + 8 read-c-string* tar-trim oct> >>gid + 12 read-c-string* tar-trim oct> >>size + 12 read-c-string* tar-trim oct> >>mtime + 8 read-c-string* tar-trim oct> >>checksum + read1 >>typeflag + 100 read-c-string* >>linkname + 6 read >>magic + 2 read >>version + 32 read-c-string* >>uname + 32 read-c-string* >>gname + 8 read tar-trim oct> >>devmajor + 8 read tar-trim oct> >>devminor + 155 read-c-string* >>prefix ; : header-checksum ( seq -- x ) 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ; -TUPLE: checksum-error ; -TUPLE: malformed-block-error ; - -SYMBOL: base-dir -SYMBOL: out-stream -SYMBOL: filename - -: (read-data-blocks) ( tar-header -- ) - 512 read [ - over tar-header-size dup 512 <= [ - head-slice - >string write - drop +: read-data-blocks ( tar-header -- ) + dup size>> 0 > [ + block-size read [ + over size>> dup block-size <= [ + head-slice >byte-array write drop + ] [ + drop write + [ block-size - ] change-size + read-data-blocks + ] if ] [ drop - >string write - dup tar-header-size 512 - over set-tar-header-size - (read-data-blocks) - ] if + ] if* ] [ drop - ] if* ; - -: read-data-blocks ( tar-header out -- ) - [ (read-data-blocks) ] with-output-stream* ; + ] if ; : parse-tar-header ( seq -- obj ) [ header-checksum ] keep over zero-checksum = [ 2drop \ tar-header new - 0 over set-tar-header-size - 0 over set-tar-header-checksum + 0 >>size + 0 >>checksum ] [ [ read-tar-header ] with-string-reader - [ tar-header-checksum = [ - \ checksum-error new throw - ] unless - ] keep + [ checksum>> = [ checksum-error ] unless ] keep ] if ; ERROR: unknown-typeflag ch ; M: unknown-typeflag summary ( obj -- str ) - ch>> 1string - "Unknown typeflag: " prepend ; + ch>> 1string "Unknown typeflag: " prepend ; -: tar-append-path ( path -- newpath ) +: tar-prepend-path ( path -- newpath ) base-dir get prepend-path ; +: read/write-blocks ( tar-header path -- ) + binary [ read-data-blocks ] with-file-writer ; + ! Normal file -: typeflag-0 - name>> tar-append-path binary - [ read-data-blocks ] keep dispose ; +: typeflag-0 ( header -- ) + dup name>> tar-prepend-path read/write-blocks ; ! Hard link : typeflag-1 ( header -- ) unknown-typeflag ; ! Symlink -: typeflag-2 ( header -- ) unknown-typeflag ; +: typeflag-2 ( header -- ) + [ name>> ] [ linkname>> ] bi + [ make-link ] 2curry ignore-errors ; ! character special : typeflag-3 ( header -- ) unknown-typeflag ; @@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Directory : typeflag-5 ( header -- ) - tar-header-name tar-append-path make-directories ; + name>> tar-prepend-path make-directories ; ! FIFO : typeflag-6 ( header -- ) unknown-typeflag ; @@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-9 ( header -- ) unknown-typeflag ; ! Global POSIX header -: typeflag-g ( header -- ) unknown-typeflag ; +: typeflag-g ( header -- ) typeflag-0 ; ! Extended POSIX header : typeflag-x ( header -- ) unknown-typeflag ; @@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str ) ! Long file name : typeflag-L ( header -- ) - [ read-data-blocks ] keep - >string [ zero? ] right-trim filename set - global [ "long filename: " write filename get . flush ] bind - filename get tar-append-path make-directories ; + drop ; + ! [ read-data-blocks ] keep + ! >string [ zero? ] right-trim filename set + ! filename get tar-prepend-path make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) unknown-typeflag ; @@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) - 512 read - global [ dup hexdump. flush ] bind - [ + block-size read dup length 512 = [ parse-tar-header - ! global [ dup tar-header-name [ print flush ] when* ] bind - dup tar-header-typeflag + dup typeflag>> { { 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] } - { CHAR: 1 [ typeflag-1 ] } + ! { CHAR: 1 [ typeflag-1 ] } { CHAR: 2 [ typeflag-2 ] } - { CHAR: 3 [ typeflag-3 ] } - { CHAR: 4 [ typeflag-4 ] } + ! { CHAR: 3 [ typeflag-3 ] } + ! { CHAR: 4 [ typeflag-4 ] } { CHAR: 5 [ typeflag-5 ] } - { CHAR: 6 [ typeflag-6 ] } - { CHAR: 7 [ typeflag-7 ] } + ! { CHAR: 6 [ typeflag-6 ] } + ! { CHAR: 7 [ typeflag-7 ] } { CHAR: g [ typeflag-g ] } - { CHAR: x [ typeflag-x ] } - { CHAR: A [ typeflag-A ] } - { CHAR: D [ typeflag-D ] } - { CHAR: E [ typeflag-E ] } - { CHAR: I [ typeflag-I ] } - { CHAR: K [ typeflag-K ] } - { CHAR: L [ typeflag-L ] } - { CHAR: M [ typeflag-M ] } - { CHAR: N [ typeflag-N ] } - { CHAR: S [ typeflag-S ] } - { CHAR: V [ typeflag-V ] } - { CHAR: X [ typeflag-X ] } - [ unknown-typeflag ] - } case - ! dup tar-header-size zero? [ - ! out-stream get [ dispose ] when - ! out-stream off - ! drop - ! ] [ - ! dup tar-header-name - ! dup parent-dir base-dir prepend-path - ! global [ dup [ . flush ] when* ] bind - ! make-directories - ! out-stream set - ! read-tar-blocks - ! ] if - (parse-tar) - ] when* ; + ! { CHAR: x [ typeflag-x ] } + ! { CHAR: A [ typeflag-A ] } + ! { CHAR: D [ typeflag-D ] } + ! { CHAR: E [ typeflag-E ] } + ! { CHAR: I [ typeflag-I ] } + ! { CHAR: K [ typeflag-K ] } + ! { CHAR: L [ typeflag-L ] } + ! { CHAR: M [ typeflag-M ] } + ! { CHAR: N [ typeflag-N ] } + ! { CHAR: S [ typeflag-S ] } + ! { CHAR: V [ typeflag-V ] } + ! { CHAR: X [ typeflag-X ] } + { f [ drop ] } + } case (parse-tar) + ] [ + drop + ] if ; -: parse-tar ( path -- obj ) - binary [ - "resource:tar-test" base-dir set - global [ nl nl nl "Starting to parse .tar..." print flush ] bind - global [ "Expanding to: " write base-dir get . flush ] bind - (parse-tar) - ] with-file-writer ; +: parse-tar ( path -- ) + normalize-path dup parent-directory base-dir [ + binary [ (parse-tar) ] with-file-reader + ] with-variable ; diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 038bfde70d..0c77a52f94 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,6 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs namespaces kernel words compiler.units sequences -ui.cocoa ; +ui ui.cocoa ; "stop-after-last-window?" get global [ diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor index ec3daab880..e39d95dfa3 100644 --- a/extra/unix/ffi/ffi.factor +++ b/extra/unix/ffi/ffi.factor @@ -9,4 +9,7 @@ C-STRUCT: utimbuf { "time_t" "actime" } { "time_t" "modtime" } ; -FUNCTION: int utime ( char* path, utimebuf* buf ) ; \ No newline at end of file +FUNCTION: int utime ( char* path, utimebuf* buf ) ; + +FUNCTION: int err_no ( ) ; +FUNCTION: char* strerror ( int errno ) ; \ No newline at end of file diff --git a/extra/unix/stat/macosx/macosx.factor b/extra/unix/stat/macosx/macosx.factor index 3741a22413..552547442a 100644 --- a/extra/unix/stat/macosx/macosx.factor +++ b/extra/unix/stat/macosx/macosx.factor @@ -30,4 +30,4 @@ FUNCTION: int lstat ( char* pathname, stat* buf ) ; : stat-st_atim stat-st_atimespec ; : stat-st_mtim stat-st_mtimespec ; -: stat-st_ctim stat-st_ctimespec ; \ No newline at end of file +: stat-st_ctim stat-st_ctimespec ; diff --git a/extra/unix/system-call/system-call.factor b/extra/unix/system-call/system-call.factor new file mode 100644 index 0000000000..bfcb9ae6ea --- /dev/null +++ b/extra/unix/system-call/system-call.factor @@ -0,0 +1,15 @@ + +USING: kernel continuations sequences math accessors inference macros + fry arrays.lib unix.ffi ; + +IN: unix.system-call + +ERROR: unix-system-call-error word args message ; + +MACRO: unix-system-call ( quot -- ) + [ ] [ infer in>> ] [ first ] tri + '[ + [ @ dup 0 < [ dup throw ] [ ] if ] + [ drop , narray , swap err_no strerror unix-system-call-error ] + recover + ] ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index fcbd96177b..c68f127226 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc structs - math namespaces system combinators vocabs.loader unix.ffi unix.types - qualified ; + math namespaces system combinators vocabs.loader qualified + unix.ffi unix.types unix.system-call ; QUALIFIED: unix.ffi @@ -27,9 +27,27 @@ TYPEDEF: ulong size_t : ESRCH 3 ; inline : EEXIST 17 ; inline +C-STRUCT: group + { "char*" "gr_name" } + { "char*" "gr_passwd" } + { "int" "gr_gid" } + { "char**" "gr_mem" } ; + +C-STRUCT: passwd + { "char*" "pw_name" } + { "char*" "pw_passwd" } + { "uid_t" "pw_uid" } + { "gid_t" "pw_gid" } + { "time_t" "pw_change" } + { "char*" "pw_class" } + { "char*" "pw_gecos" } + { "char*" "pw_dir" } + { "char*" "pw_shell" } + { "time_t" "pw_expire" } + { "int" "pw_fields" } ; + ! ! ! Unix functions LIBRARY: factor -FUNCTION: int err_no ( ) ; FUNCTION: void clear_err_no ( ) ; LIBRARY: libc @@ -64,6 +82,9 @@ FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; FUNCTION: gid_t getgid ; +FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: uid_t getuid ; @@ -78,19 +99,10 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_ FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: char* strerror ( int errno ) ; -ERROR: open-error path flags prot message ; +: open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ; -: open ( path flags prot -- int ) - 3dup unix.ffi:open - dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ; - -ERROR: utime-error path message ; - -: utime ( path buf -- ) - dupd unix.ffi:utime - 0 = [ drop ] [ err_no strerror utime-error ] if ; +: utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; diff --git a/vm/data_gc.c b/vm/data_gc.c index f44b8a7a05..6e32e14991 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -7,6 +7,8 @@ #define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n" #define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n" +/* #define GC_DEBUG */ + #ifdef GC_DEBUG #define GC_PRINT printf #else @@ -23,7 +25,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start) void init_card_decks(void) { - CELL start = data_heap->segment->start & ~(DECK_SIZE - 1); + 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); @@ -36,9 +38,9 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, { GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size); - young_size = align_page(young_size); - aging_size = align_page(aging_size); - tenured_size = align_page(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; @@ -59,23 +61,25 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, 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 + DECK_SIZE) / CARD_SIZE; + 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_SIZE) / DECK_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 = data_heap->segment->start; + 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); @@ -92,7 +96,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); } - if(alloter != data_heap->segment->end) + if(data_heap->segment->end - alloter > DECK_SIZE) critical_error("Bug in alloc_data_heap",alloter); return data_heap; @@ -119,8 +123,6 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap) free(data_heap); } -/* Every card stores the offset of the first object in that card, which must be -cleared when a generation has been cleared */ void clear_cards(CELL from, CELL to) { /* NOTE: reverse order due to heap layout. */ @@ -133,9 +135,9 @@ void clear_cards(CELL from, CELL to) void clear_decks(CELL from, CELL to) { /* NOTE: reverse order due to heap layout. */ - F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start); - F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end); - F_CARD *ptr; + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); + F_DECK *ptr; for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0; } @@ -145,7 +147,7 @@ void clear_allot_markers(CELL from, CELL to) 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); F_CARD *ptr; - for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK; + for(ptr = first_card; ptr < last_card; ptr++) *ptr = INVALID_ALLOT_MARKER; } void set_data_heap(F_DATA_HEAP *data_heap_) @@ -163,6 +165,10 @@ 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, @@ -182,10 +188,6 @@ void init_data_heap(CELL gens, secure_gc = secure_gc_; gc_reset(); - - cards_scanned = 0; - decks_scanned = 0; - code_heap_scans = 0; } /* Size of the object pointed to by a tagged pointer */ @@ -328,8 +330,11 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) { CELL offset = CARD_OFFSET(ptr); - if(offset != CARD_BASE_MASK) + if(offset != INVALID_ALLOT_MARKER) { + if(offset & TAG_MASK) + critical_error("Bad card",(CELL)ptr); + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); diff --git a/vm/data_gc.h b/vm/data_gc.h index 20692c14e6..3c21695c2c 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -68,26 +68,21 @@ the offset of the first object is set by the allocator. */ #define CARD_POINTS_TO_NURSERY 0x80 #define CARD_POINTS_TO_AGING 0x40 #define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) -#define CARD_BASE_MASK 0x3f typedef u8 F_CARD; -/* A card is 64 bytes. 6 bits is sufficient to represent every -offset within the card */ -#define CARD_SIZE 64 -#define CARD_BITS 6 +#define CARD_BITS 8 +#define CARD_SIZE (1<> CARD_BITS) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> 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); -/* this is an inefficient write barrier. compiled definitions use a more -efficient one hand-coded in assembly. the write barrier must be called -any time we are potentially storing a pointer from an older generation -to a younger one */ +/* 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; @@ -124,9 +121,8 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value) INLINE void allot_barrier(CELL address) { F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); - F_CARD b = *ptr; - F_CARD a = (address & ADDR_CARD_MASK); - *ptr = (b < a ? b : a); + if(*ptr == INVALID_ALLOT_MARKER) + *ptr = (address & ADDR_CARD_MASK); } void clear_cards(CELL from, CELL to); diff --git a/vm/run.h b/vm/run.h index e2afb08525..cc980453cf 100755 --- a/vm/run.h +++ b/vm/run.h @@ -103,11 +103,11 @@ INLINE void bput(CELL where, CELL what) INLINE CELL align(CELL a, CELL b) { - return (a + b) & ~b; + return (a + (b-1)) & ~(b-1); } -#define align8(a) align(a,7) -#define align_page(a) align(a,getpagesize() - 1) +#define align8(a) align(a,8) +#define align_page(a) align(a,getpagesize()) /* Canonical T object. It's just a word */ CELL T;