\usepackage{alltt}
\usepackage{times}
\usepackage{tabularx}
+\usepackage{epstopdf}
\usepackage{epsfig}
\usepackage{epsf}
\usepackage{amssymb}
-\usepackage{epstopdf}
\pagestyle{headings}
"/library/syntax/see.factor"
"/library/test/test.factor"
"/library/inference/test.factor"
- "/library/tools/profiler.factor"
"/library/tools/walker.factor"
"/library/tools/annotations.factor"
"/library/bootstrap/image.factor"
dup word-primitive ,
dup word-def ' ,
dup word-props ' ,
- 0 ,
- 0 ,
] make-list
swap object-tag here-as pool-object
[ emit ] each ;
[ "fsqrt" "math-internals" [ [ real ] [ float ] ] ]
[ "<word>" "words" [ [ ] [ word ] ] ]
[ "update-xt" "words" [ [ word ] [ ] ] ]
- [ "call-profiling" "profiler" [ [ integer ] [ ] ] ]
- [ "allot-profiling" "profiler" [ [ integer ] [ ] ] ]
[ "compiled?" "words" [ [ word ] [ boolean ] ] ]
[ "drop" "kernel" [ [ object ] [ ] ] ]
[ "dup" "kernel" [ [ object ] [ object object ] ] ]
#! mdest is vreg where to put the modulus. Note this has
#! precise vreg requirements.
20 17 18 DIVW ! divide in2 by in1, store result in out1
- 18 20 18 MULLW ! multiply out1 by in1, store result in in1
- 19 18 17 SUBF ! subtract in2 from in1, store result in out1.
+ 21 20 18 MULLW ! multiply out1 by in1, store result in in1
+ 19 21 17 SUBF ! subtract in2 from in1, store result in out1.
;
M: %fixnum-mod generate-node ( vop -- )
M: int-regs reg-size drop cell ;
M: int-regs push-reg drop EAX PUSH ;
-M: float-regs reg-size float-reg-size ;
+M: float-regs reg-size float-regs-size ;
M: float-regs push-reg
ESP swap reg-size [ SUB [ ESP ] ] keep
4 = [ FSTPS ] [ FSTPL ] ifte ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: profiler
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: sequences
-USE: words
-USE: vectors
-
-! The variable "only-top" toggles between
-! culminative counts, and top of call stack counts.
-SYMBOL: only-top
-
-: reset-counts ( -- )
- [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
-
-: sort-counts ( alist -- alist )
- [ swap cdr swap cdr > ] sort ;
-
-: call-count, ( word -- )
- #! Add to constructing list if call count is non-zero.
- dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-
-: counts. ( alist -- )
- sort-counts [ . ] each ;
-
-: call-counts. ( -- )
- #! Print word/call count pairs.
- [ [ call-count, ] each-word ] make-list counts. ;
-
-: profile-depth ( -- n )
- only-top get [ -1 ] [ callstack length ] ifte ;
-
-: (call-profile) ( quot -- )
- reset-counts
- profile-depth call-profiling
- call
- f call-profiling ;
-
-: call-profile ( quot -- )
- #! Execute a quotation with the CPU profiler enabled.
- (call-profile) call-counts. ;
-
-: allot-count, ( word -- )
- #! Add to constructing list if allot count is non-zero.
- dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-
-: allot-counts. ( -- alist )
- #! Print word/allot count pairs.
- [ [ allot-count, ] each-word ] make-list counts. ;
-
-: allot-profile ( quot -- )
- #! Execute a quotation with the memory profiler enabled.
- reset-counts
- profile-depth allot-profiling
- call
- f allot-profiling
- allot-counts. ;
! This will go elsewhere soon
: byte-bit ( n alien -- byte bit )
- over -3 shift alien-unsigned-1 swap 7 bitand ;
+ over -5 shift alien-unsigned-4 swap 31 bitand ;
: <bit-array> ( n -- array )
cell / ceiling <byte-array> ;
: set-bit-nth ( ? n alien -- )
[ byte-bit set-bit ] 2keep
- swap -3 shift set-alien-unsigned-1 ;
+ swap -5 shift set-alien-unsigned-4 ;
! Global variables
SYMBOL: read-fdset
: handle-fd? ( fdset task -- ? )
dup io-task-port timeout?
- [ 2drop t ] [ io-task-fd swap bit-nth ] ifte ;
+ [
+ 2drop t
+ ] [
+ io-task-fd swap 2dup bit-nth
+ >r f -rot set-bit-nth r>
+ ] ifte ;
: handle-fdset ( fdset tasks -- )
[
M: word set-word-primitive ( n w -- )
[ 3 set-integer-slot ] keep update-xt ;
-! For the profiler
-GENERIC: call-count
-M: word call-count ( w -- n ) 6 integer-slot ;
-GENERIC: set-call-count
-M: word set-call-count ( n w -- ) 6 set-integer-slot ;
-
-GENERIC: allot-count
-M: word allot-count ( w -- n ) 7 integer-slot ;
-GENERIC: set-allot-count
-M: word set-allot-count ( n w -- ) 7 set-integer-slot ;
-
: word-sort ( list -- list )
#! Sort a list of words by name.
[ swap word-name swap word-name string> ] sort ;
#include "factor.h"
-float f_test(void)
-{
- return 1.0f;
-}
-
-double d_test(void)
-{
- return 1.0;
-}
-
-float in_f_test(float x, float y, float z)
-{
- return (x + y) * z;
-}
-
-float in_i_test(int x, int y, int z)
-{
- return x + y + z;
-}
-
-void in_if_test(float x, int y, float z)
-{
- printf("%f\n",x);
- printf("%d\n",y);
- printf("%f\n",z);
-}
-
-void in_id_test(double x, int y, double z)
-{
- printf("%f\n",x);
- printf("%d\n",y);
- printf("%f\n",z);
-}
-
double to_float(CELL tagged)
{
F_RATIO* r;
if(alloter != heap_start + total_size)
fatal_error("Oops",alloter);
- allot_profiling = false;
heap_scan = false;
gc_time = 0;
minor_collections = 0;
INLINE void *allot(CELL a)
{
- if(allot_profiling)
- allot_profile_step(align8(a));
- allot_barrier(nursery.here);
return allot_zone(&nursery,a);
}
put(SLOT(obj,slot),value);
}
-void allot_profile_step(CELL a)
-{
- CELL depth = (cs - cs_bot) / CELLS;
- int i;
- CELL obj;
-
- for(i = profile_depth; i < depth; i++)
- {
- obj = get(cs_bot + i * CELLS);
- if(type_of(obj) == WORD_TYPE)
- untag_word(obj)->allot_count += a;
- }
-
- untag_word_fast(executing)->allot_count += a;
-}
-
-void primitive_allot_profiling(void)
-{
- CELL d = dpop();
- if(d == F)
- allot_profiling = false;
- else
- {
- allot_profiling = true;
- profile_depth = to_fixnum(d);
- }
-}
-
void primitive_address(void)
{
drepl(tag_bignum(s48_ulong_to_bignum(dpeek())));
type_error(type,tagged);
}
-void allot_profile_step(CELL a);
-
-bool allot_profiling;
-
INLINE CELL type_of(CELL tagged)
{
CELL tag = TAG(tagged);
CELL untagged_object_size(CELL pointer);
CELL object_size(CELL pointer);
-void primitive_allot_profiling(void);
void primitive_room(void);
void primitive_type(void);
void primitive_slot(void);
primitive_fsqrt,
primitive_word,
primitive_update_xt,
- primitive_call_profiling,
- primitive_allot_profiling,
primitive_word_compiledp,
primitive_drop,
primitive_dup,
#ifndef WIN32
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
void init_signals(void);
#endif
-
-void primitive_call_profiling(F_WORD *);
factorbug();
}
-/* Called from a signal handler. XXX - is this safe? */
-void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
-{
- CELL depth = (cs - cs_bot) / CELLS;
- int i;
- CELL obj;
- for(i = profile_depth; i < depth; i++)
- {
- obj = get(cs_bot + i * CELLS);
- if(type_of(obj) == WORD_TYPE)
- untag_word(obj)->call_count++;
- }
-
- untag_word_fast(executing)->call_count++;
-}
-
void init_signals(void)
{
struct sigaction custom_sigaction;
- struct sigaction profiling_sigaction;
struct sigaction ign_sigaction;
struct sigaction dump_sigaction;
sigemptyset(&custom_sigaction.sa_mask);
custom_sigaction.sa_sigaction = signal_handler;
custom_sigaction.sa_flags = SA_SIGINFO;
- sigemptyset(&profiling_sigaction.sa_mask);
- profiling_sigaction.sa_sigaction = call_profiling_step;
- profiling_sigaction.sa_flags = SA_SIGINFO;
sigemptyset(&dump_sigaction.sa_mask);
dump_sigaction.sa_sigaction = dump_stack_signal;
dump_sigaction.sa_flags = SA_SIGINFO;
sigaction(SIGILL,&custom_sigaction,NULL);
sigaction(SIGSEGV,&custom_sigaction,NULL);
sigaction(SIGPIPE,&ign_sigaction,NULL);
- sigaction(SIGPROF,&profiling_sigaction,NULL);
sigaction(SIGQUIT,&dump_sigaction,NULL);
}
-
-void primitive_call_profiling(F_WORD *word)
-{
- CELL d = dpop();
- if(d == F)
- {
- timerclear(&prof_timer.it_interval);
- timerclear(&prof_timer.it_value);
-
- profile_depth = 0;
- }
- else
- {
- prof_timer.it_interval.tv_sec = 0;
- prof_timer.it_interval.tv_usec = 1000;
- prof_timer.it_value.tv_sec = 0;
- prof_timer.it_value.tv_usec = 1000;
-
- profile_depth = to_fixnum(d);
- }
-
- if(setitimer(ITIMER_PROF,&prof_timer,NULL) < 0)
- io_error();
-}
word->primitive = 0;
word->def = F;
word->props = F;
- word->call_count = 0;
- word->allot_count = 0;
dpush(tag_object(word));
}
CELL def;
/* TAGGED property hash for library code */
CELL props;
- /* UNTAGGED call count incremented by profiler */
- CELL call_count;
- /* UNTAGGED amount of memory allocated in word */
- CELL allot_count;
} F_WORD;
typedef void (*XT)(F_WORD* word);
projects / factor.git / commitdiff