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

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

db4
Doug Coleman 2009-03-31 22:54:07 -05:00
parent 8e26b19cc0 3211270d5b
commit 19aa85ef49
21 changed files with 114 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/cocoa/application/application.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private cocoa.runtime sequences init summary kernel.private
assocs ; assocs ;
IN: cocoa.application IN: cocoa.application

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

@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set V{ } clone literal-table set
V{ } clone calls set V{ } clone calls set
compiling-word set compiling-word set
compiled-stack-traces? compiling-word get f ? add-literal ; compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate ( mr -- asm ) : generate ( mr -- asm )
[ [

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -312,7 +312,7 @@ generic-comparison-ops [
\ clone [ \ clone [
in-d>> first value-info literal>> { in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] } { V{ } [ [ drop { } 0 vector boa ] ] }
{ H{ } [ [ drop hashtable new ] ] } { H{ } [ [ drop 0 <hashtable> ] ] }
[ drop f ] [ drop f ]
} case } case
] "custom-inlining" set-word-prop ] "custom-inlining" set-word-prop

4
basis/core-foundation/strings/strings.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors unicode.data ; core-foundation.arrays destructors ;
IN: core-foundation.strings IN: core-foundation.strings
TYPEDEF: void* CFStringRef TYPEDEF: void* CFStringRef
@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: prepare-CFString ( string -- byte-array ) : prepare-CFString ( string -- byte-array )
[ [
dup HEX: 10ffff > dup HEX: 10ffff >
[ drop CHAR: replacement-character ] when [ drop HEX: fffd ] when
] map utf8 encode ; ] map utf8 encode ;
: <CFString> ( string -- alien ) : <CFString> ( string -- alien )

84
basis/documents/elements/elements-tests.factor
View File

@ -3,68 +3,72 @@
USING: tools.test namespaces documents documents.elements multiline ; USING: tools.test namespaces documents documents.elements multiline ;
IN: document.elements.tests IN: document.elements.tests
<document> "doc" set SYMBOL: doc
"123\nabc" "doc" get set-doc-string <document> doc set
"123\nabcé" doc get set-doc-string
! char-elt ! char-elt
[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test [ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test [ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test [ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test [ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
! word-elt ! word-elt
<document> "doc" set <document> doc set
"Hello world\nanother line" "doc" get set-doc-string "Hello world\nanother line" doc get set-doc-string
[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test [ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test [ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test [ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
! one-word-elt ! one-word-elt
[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test [ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test [ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
! line-elt ! line-elt
<document> "doc" set <document> doc set
"Hello\nworld, how are\nyou?" "doc" get set-doc-string "Hello\nworld, how are\nyou?" doc get set-doc-string
[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test [ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test [ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test [ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
! one-line-elt ! one-line-elt
[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test [ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test [ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
! page-elt ! page-elt
<document> "doc" set <document> doc set
<" First line <" First line
Second line Second line
Third line Third line
Fourth line Fourth line
Fifth line Fifth line
Sixth line"> "doc" get set-doc-string Sixth line"> doc get set-doc-string
[ { 0 0 } ] [ { 3 3 } "doc" get 4 <page-elt> prev-elt ] unit-test [ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
[ { 1 2 } ] [ { 5 2 } "doc" get 4 <page-elt> prev-elt ] unit-test [ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
[ { 4 3 } ] [ { 0 3 } "doc" get 4 <page-elt> next-elt ] unit-test [ { 4 3 } ] [ { 0 3 } doc get 4 <page-elt> next-elt ] unit-test
[ { 5 10 } ] [ { 4 2 } "doc" get 4 <page-elt> next-elt ] unit-test [ { 5 10 } ] [ { 4 2 } doc get 4 <page-elt> next-elt ] unit-test
! doc-elt ! doc-elt
[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test [ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test [ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test

40
basis/documents/elements/elements.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators documents fry kernel math sequences USING: arrays combinators documents fry kernel math sequences
unicode.categories accessors ; accessors unicode.categories unicode.breaks combinators.short-circuit ;
IN: documents.elements IN: documents.elements
GENERIC: prev-elt ( loc document elt -- newloc ) GENERIC: prev-elt ( loc document elt -- newloc )
@ -20,27 +20,32 @@ SINGLETON: char-elt
<PRIVATE <PRIVATE
: (prev-char) ( loc document quot -- loc ) : prev ( loc document quot: ( loc document -- loc ) -- loc )
{ {
{ [ pick { 0 0 } = ] [ 2drop ] } { [ pick { 0 0 } = ] [ 2drop ] }
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] } { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
[ call ] [ call ]
} cond ; inline } cond ; inline
: (next-char) ( loc document quot -- loc ) : next ( loc document quot: ( loc document -- loc ) -- loc )
{ {
{ [ 2over doc-end = ] [ 2drop ] } { [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] } { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
[ call ] [ call ]
} cond ; inline } cond ; inline
: modify-col ( loc document quot: ( col str -- col' ) -- loc )
pick [
[ [ first2 swap ] dip doc-line ] dip call
] dip =col ; inline
PRIVATE> PRIVATE>
M: char-elt prev-elt M: char-elt prev-elt
drop [ drop -1 +col ] (prev-char) ; drop [ [ last-grapheme-from ] modify-col ] prev ;
M: char-elt next-elt M: char-elt next-elt
drop [ drop 1 +col ] (next-char) ; drop [ [ first-grapheme-from ] modify-col ] next ;
SINGLETON: one-char-elt SINGLETON: one-char-elt
@ -50,21 +55,16 @@ M: one-char-elt next-elt 2drop ;
<PRIVATE <PRIVATE
: (word-elt) ( loc document quot -- loc ) : blank-at? ( n seq -- n seq ? )
pick [
[ [ first2 swap ] dip doc-line ] dip call
] dip =col ; inline
: ((word-elt)) ( n seq -- n seq ? )
2dup ?nth blank? ; 2dup ?nth blank? ;
: break-detector ( ? -- quot ) : break-detector ( ? -- quot )
'[ blank? _ xor ] ; inline '[ blank? _ xor ] ; inline
: (prev-word) ( col str ? -- col ) : prev-word ( col str ? -- col )
break-detector find-last-from drop ?1+ ; break-detector find-last-from drop ?1+ ;
: (next-word) ( col str ? -- col ) : next-word ( col str ? -- col )
[ break-detector find-from drop ] [ drop length ] 2bi or ; [ break-detector find-from drop ] [ drop length ] 2bi or ;
PRIVATE> PRIVATE>
@ -73,23 +73,23 @@ SINGLETON: one-word-elt
M: one-word-elt prev-elt M: one-word-elt prev-elt
drop drop
[ [ 1- ] dip f (prev-word) ] (word-elt) ; [ [ 1- ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt M: one-word-elt next-elt
drop drop
[ f (next-word) ] (word-elt) ; [ f next-word ] modify-col ;
SINGLETON: word-elt SINGLETON: word-elt
M: word-elt prev-elt M: word-elt prev-elt
drop drop
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ] [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
(prev-char) ; prev ;
M: word-elt next-elt M: word-elt next-elt
drop drop
[ [ ((word-elt)) (next-word) ] (word-elt) ] [ [ blank-at? next-word ] modify-col ]
(next-char) ; next ;
SINGLETON: one-line-elt SINGLETON: one-line-elt
@ -118,4 +118,4 @@ SINGLETON: doc-elt
M: doc-elt prev-elt 3drop { 0 0 } ; M: doc-elt prev-elt 3drop { 0 0 } ;
M: doc-elt next-elt drop nip doc-end ; M: doc-elt next-elt drop nip doc-end ;

2
basis/hints/hints.factor
View File

@ -119,6 +119,6 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop \ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop \ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop

6
basis/io/encodings/ascii/ascii.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.encodings kernel math io.encodings.private io.encodings.iana ; USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii IN: io.encodings.ascii
<PRIVATE <PRIVATE
@ -19,6 +19,4 @@ M: ascii encode-char
128 encode-if< ; 128 encode-if< ;
M: ascii decode-char M: ascii decode-char
128 decode-if< ; 128 decode-if< ;
ascii "ANSI_X3.4-1968" register-encoding

5
basis/io/encodings/iana/iana.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg ! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs USING: kernel strings values io.files assocs
splitting sequences io namespaces sets io.encodings.utf8 ; splitting sequences io namespaces sets
io.encodings.ascii io.encodings.utf8 ;
IN: io.encodings.iana IN: io.encodings.iana
<PRIVATE <PRIVATE
@ -52,3 +53,5 @@ e>n-table [ initial-e>n ] initialize
[ n>e-table get-global set-at ] with each [ n>e-table get-global set-at ] with each
] [ "Bad encoding registration" throw ] if* ] [ "Bad encoding registration" throw ] if*
] [ swap e>n-table get-global set-at ] 2bi ; ] [ swap e>n-table get-global set-at ] 2bi ;
ascii "ANSI_X3.4-1968" register-encoding

2
basis/syndication/syndication-docs.factor
View File

@ -36,7 +36,7 @@ HELP: download-feed
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ; { $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
HELP: parse-feed HELP: parse-feed
{ $values { "sequence" "a string or a byte array" } { "feed" feed } } { $values { "seq" "a string or a byte array" } { "feed" feed } }
{ $description "Parses a feed." } ; { $description "Parses a feed." } ;
HELP: xml>feed HELP: xml>feed

2
basis/syndication/syndication.factor
View File

@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] } { "feed" [ atom1.0 ] }
} case ; } case ;
GENERIC: parse-feed ( sequence -- feed ) GENERIC: parse-feed ( seq -- feed )
M: string parse-feed [ string>xml xml>feed ] with-html-entities ; M: string parse-feed [ string>xml xml>feed ] with-html-entities ;

1
basis/tools/deploy/shaker/shaker.factor
View File

@ -157,6 +157,7 @@ IN: tools.deploy.shaker
"specializer" "specializer"
"step-into" "step-into"
"step-into?" "step-into?"
"superclass"
"transform-n" "transform-n"
"transform-quot" "transform-quot"
"tuple-dispatch-generic" "tuple-dispatch-generic"

3
basis/unicode/breaks/breaks-tests.factor
View File

@ -9,6 +9,9 @@ IN: unicode.breaks.tests
[ 3 ] [ "\u001112\u001161\u0011abA\u000300a" [ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
dup last-grapheme head last-grapheme ] unit-test dup last-grapheme head last-grapheme ] unit-test
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
: grapheme-break-test ( -- filename ) : grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ; "vocab:unicode/breaks/GraphemeBreakTest.txt" ;

14
basis/unicode/breaks/breaks.factor
View File

@ -101,6 +101,16 @@ PRIVATE>
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ; nip swap length or 1+ ;
: first-grapheme-from ( start str -- i )
over tail-slice first-grapheme + ;
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
: last-grapheme-from ( end str -- i )
swap head-slice last-grapheme ;
<PRIVATE <PRIVATE
: >pieces ( str quot: ( str -- i ) -- graphemes ) : >pieces ( str quot: ( str -- i ) -- graphemes )
@ -114,10 +124,6 @@ PRIVATE>
: string-reverse ( str -- rts ) : string-reverse ( str -- rts )
>graphemes reverse concat ; >graphemes reverse concat ;
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
<PRIVATE <PRIVATE
graphemes init-table table graphemes init-table table

4
core/hashtables/hashtables.factor
View File

@ -79,7 +79,7 @@ TUPLE: hashtable
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep [ [ >alist ] [ assoc-size 1+ ] bi ] keep
[ reset-hash ] keep [ reset-hash ] keep
swap (rehash) ; inline swap (rehash) ;
: ?grow-hash ( hash -- ) : ?grow-hash ( hash -- )
dup hash-large? [ dup hash-large? [
@ -95,7 +95,7 @@ TUPLE: hashtable
PRIVATE> PRIVATE>
: <hashtable> ( n -- hash ) : <hashtable> ( n -- hash )
hashtable new [ reset-hash ] keep ; hashtable new [ reset-hash ] keep ; inline
M: hashtable at* ( key hash -- value ? ) M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;

2
core/namespaces/namespaces.factor
View File

@ -30,6 +30,6 @@ PRIVATE>
: bind ( ns quot -- ) swap >n call ndrop ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ; : counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) H{ } clone swap bind ; inline : with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline : initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline

2
vm/callstack.c
View File

@ -103,7 +103,7 @@ CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame) CELL frame_executing(F_STACK_FRAME *frame)
{ {
F_CODE_BLOCK *compiled = frame_code(frame); F_CODE_BLOCK *compiled = frame_code(frame);
if(compiled->literals == F) if(compiled->literals == F || !stack_traces_p())
return F; return F;
else else
{ {

11
vm/code_block.c
View File

@ -11,7 +11,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{ {
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
CELL index = 1; CELL index = stack_traces_p() ? 1 : 0;
F_REL *rel = (F_REL *)(relocation + 1); F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
@ -368,11 +368,6 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format)
} }
} }
bool stack_traces_p(void)
{
return to_boolean(userenv[STACK_TRACES_ENV]);
}
CELL compiled_code_format(void) CELL compiled_code_format(void)
{ {
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]); return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
@ -429,6 +424,10 @@ F_CODE_BLOCK *add_code_block(
UNREGISTER_ROOT(relocation); UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals); UNREGISTER_ROOT(literals);
/* slight space optimization */
if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
literals = F;
/* compiled header */ /* compiled header */
compiled->block.type = type; compiled->block.type = type;
compiled->block.last_scan = NURSERY; compiled->block.last_scan = NURSERY;

5
vm/code_block.h
View File

@ -75,7 +75,10 @@ void relocate_code_block(F_CODE_BLOCK *relocating);
CELL compiled_code_format(void); CELL compiled_code_format(void);
bool stack_traces_p(void); INLINE bool stack_traces_p(void)
{
return userenv[STACK_TRACES_ENV] != F;
}
F_CODE_BLOCK *add_code_block( F_CODE_BLOCK *add_code_block(
CELL type, CELL type,

11
vm/debug.c
View File

@ -311,7 +311,7 @@ void find_data_references(CELL look_for_)
/* Dump all code blocks for debugging */ /* Dump all code blocks for debugging */
void dump_code_heap(void) void dump_code_heap(void)
{ {
CELL size = 0; CELL reloc_size = 0, literal_size = 0;
F_BLOCK *scan = first_block(&code_heap); F_BLOCK *scan = first_block(&code_heap);
@ -324,11 +324,13 @@ void dump_code_heap(void)
status = "free"; status = "free";
break; break;
case B_ALLOCATED: case B_ALLOCATED:
size += object_size(((F_CODE_BLOCK *)scan)->relocation); reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "allocated"; status = "allocated";
break; break;
case B_MARKED: case B_MARKED:
size += object_size(((F_CODE_BLOCK *)scan)->relocation); reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "marked"; status = "marked";
break; break;
default: default:
@ -343,7 +345,8 @@ void dump_code_heap(void)
scan = next_block(&code_heap,scan); scan = next_block(&code_heap,scan);
} }
print_cell(size); print_string(" bytes of relocation data\n"); print_cell(reloc_size); print_string(" bytes of relocation data\n");
print_cell(literal_size); print_string(" bytes of literal data\n");
} }
void factorbug(void) void factorbug(void)

3
vm/quotations.c
View File

@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(literals); GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals); REGISTER_ROOT(literals);
GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F); if(stack_traces_p())
GROWABLE_ARRAY_ADD(literals,quot);
bool stack_frame = jit_stack_frame_p(untag_object(array)); bool stack_frame = jit_stack_frame_p(untag_object(array));