Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
0e37ec3968
|
|
@ -57,7 +57,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
|
|||
] computing-dependencies ;
|
||||
|
||||
: compile-failed ( word error -- )
|
||||
dup inference-error? [ rethrow ] unless
|
||||
! dup inference-error? [ rethrow ] unless
|
||||
f pick compiled get set-at
|
||||
swap compiler-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces assocs prettyprint io sequences
|
||||
sorting continuations debugger math ;
|
||||
|
|
@ -24,6 +24,8 @@ SYMBOL: with-compiler-errors?
|
|||
|
||||
GENERIC: compiler-warning? ( error -- ? )
|
||||
|
||||
M: object compiler-warning? drop f ;
|
||||
|
||||
: (:errors) ( -- assoc )
|
||||
compiler-errors get-global
|
||||
[ nip compiler-warning? not ] assoc-subset ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
|
||||
kernel kernel.private math memory namespaces sequences words
|
||||
assocs generator generator.registers generator.fixup system
|
||||
layouts classes words.private alien combinators ;
|
||||
layouts classes words.private alien combinators
|
||||
compiler.constants ;
|
||||
IN: cpu.ppc.architecture
|
||||
|
||||
TUPLE: ppc-backend ;
|
||||
|
|
@ -37,7 +38,7 @@ TUPLE: ppc-backend ;
|
|||
: local@ ( n -- x )
|
||||
reserved-area-size param-save-size + + ; inline
|
||||
|
||||
: factor-area-size 4 cells ;
|
||||
: factor-area-size 2 cells ;
|
||||
|
||||
: next-save ( n -- i ) cell - ;
|
||||
|
||||
|
|
@ -77,7 +78,7 @@ M: ppc-backend load-indirect ( obj reg -- )
|
|||
dup 0 LWZ ;
|
||||
|
||||
M: ppc-backend %save-word-xt ( -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
|
||||
|
||||
M: ppc-backend %prologue ( n -- )
|
||||
0 MFLR
|
||||
|
|
@ -99,35 +100,15 @@ M: ppc-backend %epilogue ( n -- )
|
|||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
M: ppc-backend %profiler-prologue ( word -- )
|
||||
3 load-indirect
|
||||
4 3 profile-count-offset LWZ
|
||||
4 4 1 v>operand ADDI
|
||||
4 3 profile-count-offset STW ;
|
||||
|
||||
M: ppc-backend %call-label ( label -- ) BL ;
|
||||
|
||||
M: ppc-backend %jump-label ( label -- ) B ;
|
||||
|
||||
: %prepare-primitive ( word -- )
|
||||
#! Save stack pointer to stack_chain->callstack_top, load XT
|
||||
4 1 MR
|
||||
0 11 LOAD32
|
||||
rc-absolute-ppc-2/2 rel-word ;
|
||||
|
||||
: (%call) 11 MTLR BLRL ;
|
||||
|
||||
M: ppc-backend %call-primitive ( word -- )
|
||||
%prepare-primitive (%call) ;
|
||||
|
||||
: (%jump) 11 MTCTR BCTR ;
|
||||
|
||||
M: ppc-backend %jump-primitive ( word -- )
|
||||
%prepare-primitive (%jump) ;
|
||||
|
||||
M: ppc-backend %jump-t ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BNE ;
|
||||
|
||||
: (%call) 11 MTLR BLRL ;
|
||||
|
||||
: dispatch-template ( word-table# quot -- )
|
||||
[
|
||||
>r
|
||||
|
|
@ -145,7 +126,7 @@ M: ppc-backend %call-dispatch ( word-table# -- )
|
|||
[ (%call) ] dispatch-template ;
|
||||
|
||||
M: ppc-backend %jump-dispatch ( word-table# -- )
|
||||
[ %epilogue-later (%jump) ] dispatch-template ;
|
||||
[ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
|
||||
|
||||
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ big-endian on
|
|||
temp-reg dup 0 LWZ
|
||||
! Bump profiling counter
|
||||
aux-reg temp-reg profile-count-offset LWZ
|
||||
aux-reg dup 1 tag-fixnum ADD
|
||||
aux-reg dup 1 tag-fixnum ADDI
|
||||
aux-reg temp-reg profile-count-offset STW
|
||||
! Load word->code
|
||||
aux-reg temp-reg word-code-offset LWZ
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
|
|||
sbufs vectors system layouts math.floats.private
|
||||
classes tuples tuples.private sbufs.private vectors.private
|
||||
strings.private slots.private combinators bit-arrays
|
||||
float-arrays ;
|
||||
float-arrays compiler.constants ;
|
||||
IN: cpu.ppc.intrinsics
|
||||
|
||||
: %slot-literal-known-tag
|
||||
|
|
|
|||
|
|
@ -13,5 +13,3 @@ namespaces alien.c-types kernel system combinators ;
|
|||
} cond
|
||||
|
||||
T{ ppc-backend } compiler-backend set-global
|
||||
|
||||
6 cells profiler-prologue set-global
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ M: object init-io ;
|
|||
: stdout 12 getenv ;
|
||||
|
||||
M: object init-stdio
|
||||
stdin stdout <duplex-c-stream> stdio set ;
|
||||
stdin stdout <duplex-c-stream> stdio set-global ;
|
||||
|
||||
M: object io-multiplex (sleep) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ HELP: vocabs
|
|||
{ $description "Outputs a sequence of all defined vocabulary names." } ;
|
||||
|
||||
HELP: vocab
|
||||
{ $values { "name" string } { "vocab" vocab } }
|
||||
{ $values { "vocab-spec" "a vocabulary specifier" } { "vocab" vocab } }
|
||||
{ $description "Outputs a named vocabulary, or " { $link f } " if no vocabulary with this name exists." }
|
||||
{ $class-description "Instances represent vocabularies." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,5 +8,3 @@ USING: kernel vocabs vocabs.loader sequences system ;
|
|||
"ui.cocoa.tools" require
|
||||
] when
|
||||
] when
|
||||
|
||||
macosx? [ "ui.tools.deploy" require ] when
|
||||
|
|
|
|||
|
|
@ -1,5 +1,18 @@
|
|||
USING: cocoa.application debugger quotations help.markup
|
||||
help.syntax strings alien core-foundation ;
|
||||
USING: debugger quotations help.markup help.syntax strings alien
|
||||
core-foundation ;
|
||||
IN: cocoa.application
|
||||
|
||||
HELP: <NSString>
|
||||
{ $values { "str" string } { "alien" alien } }
|
||||
{ $description "Allocates an autoreleased " { $snippet "CFString" } "." } ;
|
||||
|
||||
{ <NSString> <CFString> CF>string } related-words
|
||||
|
||||
HELP: <NSArray>
|
||||
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
|
||||
{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
|
||||
|
||||
{ <NSArray> <CFArray> } related-words
|
||||
|
||||
HELP: with-autorelease-pool
|
||||
{ $values { "quot" quotation } }
|
||||
|
|
|
|||
|
|
@ -5,6 +5,10 @@ cocoa cocoa.classes cocoa.runtime sequences threads debugger
|
|||
init inspector kernel.private ;
|
||||
IN: cocoa.application
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
||||
: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
|
||||
|
||||
: NSApplicationDelegateReplySuccess 0 ;
|
||||
: NSApplicationDelegateReplyCancel 1 ;
|
||||
: NSApplicationDelegateReplyFailure 2 ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: cocoa cocoa.messages help.markup help.syntax strings
|
||||
USING: cocoa.messages help.markup help.syntax strings
|
||||
alien core-foundation ;
|
||||
IN: cocoa
|
||||
|
||||
HELP: ->
|
||||
{ $syntax "-> selector" }
|
||||
|
|
@ -15,18 +16,6 @@ HELP: SUPER->
|
|||
|
||||
{ send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
|
||||
|
||||
HELP: <NSString>
|
||||
{ $values { "str" string } { "alien" alien } }
|
||||
{ $description "Allocates an autoreleased " { $snippet "CFString" } "." } ;
|
||||
|
||||
{ <NSString> <CFString> CF>string } related-words
|
||||
|
||||
HELP: <NSArray>
|
||||
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
|
||||
{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
|
||||
|
||||
{ <NSArray> <CFArray> } related-words
|
||||
|
||||
ARTICLE: "objc-calling" "Calling Objective C code"
|
||||
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
|
||||
{ $subsection import-objc-class }
|
||||
|
|
|
|||
|
|
@ -12,8 +12,6 @@ CLASS: {
|
|||
[ data-gc "x" set 2drop ]
|
||||
} ;
|
||||
|
||||
recompile
|
||||
|
||||
: test-foo
|
||||
Foo -> alloc -> init
|
||||
dup 1.0 2.0 101.0 102.0 <NSRect> -> foo:
|
||||
|
|
@ -36,13 +34,11 @@ CLASS: {
|
|||
[ 2drop test-foo "x" get ]
|
||||
} ;
|
||||
|
||||
recompile
|
||||
|
||||
Bar [
|
||||
-> alloc -> init
|
||||
dup -> bar "x" set
|
||||
-> release
|
||||
] compile-1
|
||||
] compile-call
|
||||
|
||||
[ 1 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2 ] [ "x" get NSRect-y ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler io kernel cocoa.runtime cocoa.subclassing
|
||||
cocoa.messages cocoa.types sequences words vocabs parser
|
||||
core-foundation namespaces assocs hashtables ;
|
||||
core-foundation namespaces assocs hashtables definitions ;
|
||||
IN: cocoa
|
||||
|
||||
: (remember-send) ( selector variable -- )
|
||||
|
|
@ -32,37 +32,36 @@ SYMBOL: super-sent-messages
|
|||
|
||||
{
|
||||
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
|
||||
} [ words ] map concat compile-batch
|
||||
} [ words ] map concat compile
|
||||
|
||||
"Importing Cocoa classes..." print
|
||||
{
|
||||
"NSApplication"
|
||||
"NSArray"
|
||||
"NSAutoreleasePool"
|
||||
"NSBundle"
|
||||
"NSError"
|
||||
"NSEvent"
|
||||
"NSException"
|
||||
"NSMenu"
|
||||
"NSMenuItem"
|
||||
"NSNib"
|
||||
"NSNotification"
|
||||
"NSNotificationCenter"
|
||||
"NSObject"
|
||||
"NSOpenGLContext"
|
||||
"NSOpenGLPixelFormat"
|
||||
"NSOpenGLView"
|
||||
"NSOpenPanel"
|
||||
"NSPasteboard"
|
||||
"NSResponder"
|
||||
"NSSavePanel"
|
||||
"NSView"
|
||||
"NSWindow"
|
||||
"NSWorkspace"
|
||||
} [
|
||||
[ ] import-objc-class
|
||||
] each
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
||||
: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
|
||||
[
|
||||
{
|
||||
"NSApplication"
|
||||
"NSArray"
|
||||
"NSAutoreleasePool"
|
||||
"NSBundle"
|
||||
"NSError"
|
||||
"NSEvent"
|
||||
"NSException"
|
||||
"NSMenu"
|
||||
"NSMenuItem"
|
||||
"NSNib"
|
||||
"NSNotification"
|
||||
"NSNotificationCenter"
|
||||
"NSObject"
|
||||
"NSOpenGLContext"
|
||||
"NSOpenGLPixelFormat"
|
||||
"NSOpenGLView"
|
||||
"NSOpenPanel"
|
||||
"NSPasteboard"
|
||||
"NSResponder"
|
||||
"NSSavePanel"
|
||||
"NSView"
|
||||
"NSWindow"
|
||||
"NSWorkspace"
|
||||
} [
|
||||
[ ] import-objc-class
|
||||
] each
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.dialogs help.markup help.syntax ;
|
||||
USING: help.markup help.syntax ;
|
||||
IN: cocoa.dialogs
|
||||
|
||||
HELP: <NSOpenPanel>
|
||||
{ $values { "panel" "an " { $snippet "NSOpenPanel" } } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.messages help.markup help.syntax strings alien ;
|
||||
USING: help.markup help.syntax strings alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
HELP: send
|
||||
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: cocoa.messages
|
|||
: sender-stub ( method function -- word )
|
||||
[ sender-stub-name f <word> dup ] 2keep
|
||||
over first large-struct? [ "_stret" append ] when
|
||||
make-sender define-compound dup compile ;
|
||||
make-sender define ;
|
||||
|
||||
SYMBOL: message-senders
|
||||
SYMBOL: super-message-senders
|
||||
|
|
@ -196,7 +196,7 @@ H{
|
|||
: define-objc-class-word ( name quot -- )
|
||||
[
|
||||
over , , \ unless-defined , dup , \ objc-class ,
|
||||
] [ ] make >r "cocoa.classes" create r> define-compound ;
|
||||
] [ ] make >r "cocoa.classes" create r> define ;
|
||||
|
||||
: import-objc-class ( name quot -- )
|
||||
2dup unless-defined
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.markup help.syntax cocoa.nibs strings ;
|
||||
USING: help.markup help.syntax strings ;
|
||||
IN: cocoa.nibs
|
||||
|
||||
HELP: load-nib
|
||||
{ $values { "name" string } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.pasteboard help.markup help.syntax strings ;
|
||||
USING: help.markup help.syntax strings ;
|
||||
IN: cocoa.pasteboard
|
||||
|
||||
HELP: pasteboard-string?
|
||||
{ $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: cocoa.subclassing help.markup help.syntax strings alien
|
||||
hashtables ;
|
||||
USING: help.markup help.syntax strings alien hashtables ;
|
||||
IN: cocoa.subclassing
|
||||
|
||||
HELP: define-objc-class
|
||||
{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays assocs combinators compiler
|
||||
hashtables kernel libc math namespaces parser sequences words
|
||||
cocoa.messages cocoa.runtime ;
|
||||
cocoa.messages cocoa.runtime definitions ;
|
||||
IN: cocoa.subclassing
|
||||
|
||||
: init-method ( method alien -- )
|
||||
|
|
@ -86,7 +86,9 @@ IN: cocoa.subclassing
|
|||
] [ ] make define-temp ;
|
||||
|
||||
: prepare-methods ( methods -- methods )
|
||||
[ first4 prepare-method 3array ] map ;
|
||||
[
|
||||
[ first4 prepare-method 3array ] map
|
||||
] with-compilation-unit ;
|
||||
|
||||
: redefine-objc-methods ( imeth name -- )
|
||||
dup class-exists? [
|
||||
|
|
@ -102,16 +104,13 @@ SYMBOL: +superclass+
|
|||
: define-objc-class ( imeth hash -- )
|
||||
clone [
|
||||
prepare-methods
|
||||
+name+ get "cocoa.classes" create drop
|
||||
+name+ get 2dup redefine-objc-methods swap [
|
||||
+protocols+ get , +superclass+ get , +name+ get , ,
|
||||
\ (define-objc-class) ,
|
||||
] [ ] make import-objc-class
|
||||
] bind ;
|
||||
|
||||
: define-objc-class-early ( hash -- )
|
||||
+name+ swap at "cocoa.classes" create drop ;
|
||||
|
||||
: CLASS:
|
||||
parse-definition unclip >r parsed r>
|
||||
>hashtable dup define-objc-class-early parsed
|
||||
\ define-objc-class parsed ; parsing
|
||||
parse-definition unclip
|
||||
>hashtable define-objc-class ; parsing
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.types math help.markup help.syntax ;
|
||||
USING: math help.markup help.syntax ;
|
||||
IN: cocoa.types
|
||||
|
||||
HELP: <NSRect>
|
||||
{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.views help.syntax help.markup ;
|
||||
USING: help.syntax help.markup ;
|
||||
IN: cocoa.views
|
||||
|
||||
HELP: <PixelFormat>
|
||||
{ $values { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: cocoa.windows help.markup help.syntax ;
|
||||
USING: help.markup help.syntax ;
|
||||
IN: cocoa.windows
|
||||
|
||||
HELP: <NSWindow>
|
||||
{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: core-foundation alien strings arrays help.markup
|
||||
help.syntax ;
|
||||
USING: alien strings arrays help.markup help.syntax ;
|
||||
IN: core-foundation
|
||||
|
||||
HELP: CF>array
|
||||
{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
|
||||
|
|
|
|||
|
|
@ -187,4 +187,4 @@ M: unix-io init-io ( -- )
|
|||
] bind ;
|
||||
|
||||
M: unix-io init-stdio ( -- )
|
||||
0 1 handle>duplex-stream stdio set ;
|
||||
0 1 handle>duplex-stream stdio set-global ;
|
||||
|
|
|
|||
|
|
@ -42,4 +42,4 @@ M: windows-ce-io init-stdio ( -- )
|
|||
0 _getstdfilex _fileno
|
||||
1 _getstdfilex _fileno
|
||||
] if <win32-duplex-stream>
|
||||
] with-variable stdio set ;
|
||||
] with-variable stdio set-global ;
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@ MEMO: fib ( m -- n )
|
|||
|
||||
[ 89 ] [ 10 fib ] unit-test
|
||||
|
||||
[ "USE: memoize MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" parse ] unit-test-fails
|
||||
[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -1,33 +1,51 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: effects words kernel sequences slots slots.private
|
||||
assocs parser mirrors ;
|
||||
assocs parser mirrors namespaces math vocabs ;
|
||||
IN: new-slots
|
||||
|
||||
: reader-effect T{ effect f 1 1 } ; inline
|
||||
|
||||
: writer-effect T{ effect f 2 0 } ; inline
|
||||
|
||||
: create-accessor ( name effect -- word )
|
||||
>r "accessors" create dup r>
|
||||
"declared-effect" set-word-prop ;
|
||||
|
||||
: reader-effect T{ effect f { "object" } { "value" } } ; inline
|
||||
|
||||
: reader-word ( name -- word )
|
||||
">>" append reader-effect create-accessor ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
">>" swap append writer-effect create-accessor ;
|
||||
|
||||
: define-reader ( class slot name -- )
|
||||
reader-word [ slot ] define-slot-word ;
|
||||
|
||||
: writer-effect T{ effect f { "value" "object" } { } } ; inline
|
||||
|
||||
: writer-word ( name -- word )
|
||||
">>" swap append writer-effect create-accessor ;
|
||||
|
||||
: define-writer ( class slot name -- )
|
||||
writer-word [ set-slot ] define-slot-word ;
|
||||
|
||||
: changer-effect T{ effect f { "object" "quot" } } ; inline
|
||||
|
||||
: changer-word ( name -- word )
|
||||
"change-" swap append changer-effect create-accessor ;
|
||||
|
||||
: define-changer ( name -- )
|
||||
dup changer-word dup deferred? [
|
||||
[
|
||||
[ over >r >r ] %
|
||||
over reader-word ,
|
||||
[ r> call r> ] %
|
||||
swap writer-word ,
|
||||
] [ ] make define
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: define-new-slot ( class slot name -- )
|
||||
dup define-changer 3dup define-reader define-writer ;
|
||||
|
||||
: define-new-slots ( tuple-class -- )
|
||||
[ "slot-names" word-prop <enum> >alist ] keep
|
||||
[
|
||||
swap first2 >r 2 + r> 3dup define-reader define-writer
|
||||
] curry each ;
|
||||
[ swap first2 >r 4 + r> define-new-slot ] curry each ;
|
||||
|
||||
: NEW-SLOTS: scan-word define-new-slots ; parsing
|
||||
|
||||
"accessors" create-vocab drop
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax parser-combinators ;
|
||||
USING: help.markup help.syntax ;
|
||||
IN: parser-combinators
|
||||
|
||||
HELP: list-of
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -3,13 +3,13 @@ quotations io strings words definitions ;
|
|||
IN: tools.profiler
|
||||
|
||||
ARTICLE: "profiling" "Profiling code"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler has three main limitations:"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
|
||||
{ $list
|
||||
"Calls to primitives are not counted."
|
||||
{ "Calls to " { $link POSTPONE: inline } " words from words compiled with the optimizing compiler are not counted." }
|
||||
"Certain types of tail-recursive words compiled with the optimizing compiler will only count the initial invocation of the word, not every tail call."
|
||||
"The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
|
||||
{ "Calls to " { $link POSTPONE: inline } " words are not counted.." }
|
||||
"Tail-recursive loops will only count the initial invocation of the word, not every tail call."
|
||||
}
|
||||
"Quotations can be passed to a combinator which calls them with word call counting enabled:"
|
||||
"Quotations can be passed to a combinator which calls them with the profiler enabled:"
|
||||
{ $subsection profile }
|
||||
"After a quotation has been profiled, call counts can be presented in various ways:"
|
||||
{ $subsection profile. }
|
||||
|
|
|
|||
|
|
@ -57,8 +57,11 @@ C: <annotation> annotation
|
|||
: paste-link ( paste -- link )
|
||||
paste-n number>string [ show-paste ] curry quot-link ;
|
||||
|
||||
: safe-head ( seq n -- seq' )
|
||||
over length min head ;
|
||||
|
||||
: paste-feed ( -- entries )
|
||||
get-pastebin pastebin-pastes <reversed> [
|
||||
get-pastebin pastebin-pastes <reversed> 20 safe-head [
|
||||
{
|
||||
paste-summary
|
||||
paste-link
|
||||
|
|
|
|||
|
|
@ -216,8 +216,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
|
|||
REGISTER_UNTAGGED(callstack);
|
||||
REGISTER_UNTAGGED(quot);
|
||||
|
||||
if(quot->compiledp == F)
|
||||
jit_compile(tag_object(quot));
|
||||
jit_compile(tag_object(quot),true);
|
||||
|
||||
UNREGISTER_UNTAGGED(quot);
|
||||
UNREGISTER_UNTAGGED(callstack);
|
||||
|
|
|
|||
|
|
@ -303,10 +303,10 @@ void set_word_code(F_WORD *word, F_COMPILED *compiled)
|
|||
}
|
||||
|
||||
/* Allocates memory */
|
||||
void default_word_code(F_WORD *word)
|
||||
void default_word_code(F_WORD *word, bool relocate)
|
||||
{
|
||||
REGISTER_UNTAGGED(word);
|
||||
jit_compile(word->def);
|
||||
jit_compile(word->def,relocate);
|
||||
UNREGISTER_UNTAGGED(word);
|
||||
|
||||
word->code = untag_quotation(word->def)->code;
|
||||
|
|
@ -336,7 +336,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
|
|||
{
|
||||
REGISTER_UNTAGGED(alist);
|
||||
REGISTER_UNTAGGED(word);
|
||||
default_word_code(word);
|
||||
default_word_code(word,false);
|
||||
UNREGISTER_UNTAGGED(word);
|
||||
UNREGISTER_UNTAGGED(alist);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ typedef struct {
|
|||
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
|
||||
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
|
||||
|
||||
void default_word_code(F_WORD *word);
|
||||
void default_word_code(F_WORD *word, bool relocate);
|
||||
|
||||
void set_word_code(F_WORD *word, F_COMPILED *compiled);
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ void do_stage1_init(void)
|
|||
if(type_of(obj) == WORD_TYPE)
|
||||
{
|
||||
F_WORD *word = untag_object(obj);
|
||||
default_word_code(word);
|
||||
default_word_code(word,false);
|
||||
update_word_xt(word);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
|
|||
|
||||
CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
|
||||
| (to_fixnum(array_nth(quadruple,1)) << 8));
|
||||
CELL rel_offset = array_nth(quadruple,3);
|
||||
CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
|
||||
|
||||
CELL relocation = allot_array_2(rel_type,rel_offset);
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
|
|||
rel.type = to_fixnum(rel_type)
|
||||
| (to_fixnum(rel_class) << 8)
|
||||
| (rel_argument << 16);
|
||||
rel.offset = code_length * code_format + to_fixnum(offset);
|
||||
rel.offset = (code_length + to_fixnum(offset)) * code_format;
|
||||
}
|
||||
|
||||
return rel;
|
||||
|
|
@ -95,7 +95,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
|
|||
}
|
||||
|
||||
/* Might GC */
|
||||
void jit_compile(CELL quot)
|
||||
void jit_compile(CELL quot, bool relocate)
|
||||
{
|
||||
if(untag_quotation(quot)->compiledp != F)
|
||||
return;
|
||||
|
|
@ -230,11 +230,10 @@ void jit_compile(CELL quot)
|
|||
untag_object(words),
|
||||
untag_object(literals));
|
||||
|
||||
/* We must do this before relocate_code_block(), so that
|
||||
relocation knows the quotation's XT. */
|
||||
set_quot_xt(untag_object(quot),compiled);
|
||||
|
||||
iterate_code_heap_step(compiled,relocate_code_block);
|
||||
if(relocate)
|
||||
iterate_code_heap_step(compiled,relocate_code_block);
|
||||
|
||||
UNREGISTER_ROOT(words);
|
||||
UNREGISTER_ROOT(literals);
|
||||
|
|
@ -352,7 +351,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
|
|||
{
|
||||
stack_chain->callstack_top = stack;
|
||||
REGISTER_ROOT(quot);
|
||||
jit_compile(quot);
|
||||
jit_compile(quot,true);
|
||||
UNREGISTER_ROOT(quot);
|
||||
return quot;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
|
||||
void jit_compile(CELL quot);
|
||||
void jit_compile(CELL quot, bool relocate);
|
||||
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
|
||||
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
|
||||
void uncurry(CELL obj);
|
||||
|
|
|
|||
|
|
@ -511,7 +511,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
|
|||
word->profiling = NULL;
|
||||
|
||||
REGISTER_UNTAGGED(word);
|
||||
default_word_code(word);
|
||||
default_word_code(word,true);
|
||||
UNREGISTER_UNTAGGED(word);
|
||||
|
||||
REGISTER_UNTAGGED(word);
|
||||
|
|
|
|||
Loading…
Reference in New Issue