vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
+ vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/debug.o \
vm/factor.o \
vm/full_collector.o \
vm/gc.o \
- vm/heap.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
- vm/old_space.o \
+ vm/object_start_map.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.data alien.strings parser
-threads words kernel.private kernel io.encodings.utf8 eval ;
+USING: accessors alien alien.c-types alien.data alien.strings
+parser threads words kernel.private kernel io.encodings.utf8
+eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
- "void*" { "char*" } "cdecl"
+ void* { char* } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
- "void" { } "cdecl" [ yield ] alien-callback ;
+ void { } "cdecl" [ yield ] alien-callback ;
: sleep-callback ( -- callback )
- "void" { "long" } "cdecl" [ sleep ] alien-callback ;
+ void { long } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline
: here-as ( tag -- pointer ) here bitor ;
+: (align-here) ( alignment -- )
+ [ here neg ] dip rem
+ [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
+
: align-here ( -- )
- here 8 mod 4 = [ 0 emit ] when ;
+ data-alignment get (align-here) ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
M: float '
[
float [
- align-here double>bits emit-64
+ 8 (align-here) double>bits emit-64
] emit-object
] cache-eql-object ;
[
byte-array [
dup length emit-fixnum
+ bootstrap-cell 4 = [ 0 emit 0 emit ] when
pad-bytes emit-bytes
] emit-object
] cache-eq-object ;
"stage2: deployment mode" print
] [
"debugger" require
- "inspector" require
- "tools.errors" require
"listener" require
"none" require
] if
IN: bootstrap.tools
{
+ "editors"
"inspector"
"bootstrap.image"
+ "see"
"tools.annotations"
"tools.crossref"
"tools.errors"
"vocabs.hierarchy"
"vocabs.refresh"
"vocabs.refresh.monitor"
- "editors"
} [ require ] each
{ +superclass+ "NSObject" }
}
-{ "perform:" "void" { "id" "SEL" "id" }
+{ "perform:" void { id SEL id }
[ 2drop callbacks get at try ]
}
-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
[
drop
dup callbacks get delete-at
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math core-graphics.types ;
+compiler kernel namespaces cocoa.classes cocoa.runtime
+tools.test memory compiler.units math core-graphics.types ;
+FROM: alien.c-types => int void ;
IN: cocoa.tests
CLASS: {
{ +name+ "Foo" }
} {
"foo:"
- "void"
- { "id" "SEL" "NSRect" }
+ void
+ { id SEL NSRect }
[ gc "x" set 2drop ]
} ;
{ +name+ "Bar" }
} {
"bar"
- "NSRect"
- { "id" "SEL" }
+ NSRect
+ { id SEL }
[ 2drop test-foo "x" get ]
} ;
{ +name+ "Bar" }
} {
"bar"
- "NSRect"
- { "id" "SEL" }
+ NSRect
+ { id SEL }
[ 2drop test-foo "x" get ]
} {
"babb"
- "int"
- { "id" "SEL" "int" }
+ int
+ { id SEL int }
[ 2nip sq ]
} ;
IN: cocoa.messages
HELP: send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
HELP: super-send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
HELP: objc-class
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
-stack-checker kernel math namespaces make quotations sequences
-strings words cocoa.runtime io macros memoize io.encodings.utf8
-effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays ;
+core-graphics.types stack-checker kernel math namespaces make
+quotations sequences strings words cocoa.runtime cocoa.types io
+macros memoize io.encodings.utf8 effects layouts libc
+libc.private lexer init core-foundation fry generalizations
+specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
SPECIALIZED-ARRAY: void*
SYMBOL: objc>alien-types
H{
- { "c" "char" }
- { "i" "int" }
- { "s" "short" }
- { "C" "uchar" }
- { "I" "uint" }
- { "S" "ushort" }
- { "f" "float" }
- { "d" "double" }
- { "B" "bool" }
- { "v" "void" }
- { "*" "char*" }
- { "?" "unknown_type" }
- { "@" "id" }
- { "#" "Class" }
- { ":" "SEL" }
+ { "c" c:char }
+ { "i" c:int }
+ { "s" c:short }
+ { "C" c:uchar }
+ { "I" c:uint }
+ { "S" c:ushort }
+ { "f" c:float }
+ { "d" c:double }
+ { "B" c:bool }
+ { "v" c:void }
+ { "*" c:char* }
+ { "?" unknown_type }
+ { "@" id }
+ { "#" Class }
+ { ":" SEL }
}
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "l" "long" }
- { "q" "longlong" }
- { "L" "ulong" }
- { "Q" "ulonglong" }
+ { "l" c:long }
+ { "q" c:longlong }
+ { "L" c:ulong }
+ { "Q" c:ulonglong }
} ] }
{ 8 [ H{
- { "l" "long32" }
- { "q" "long" }
- { "L" "ulong32" }
- { "Q" "ulong" }
+ { "l" long32 }
+ { "q" long }
+ { "L" ulong32 }
+ { "Q" ulong }
} ] }
} case
assoc-union objc>alien-types set-global
+SYMBOL: objc>struct-types
+
+H{
+ { "_NSPoint" NSPoint }
+ { "NSPoint" NSPoint }
+ { "CGPoint" NSPoint }
+ { "_NSRect" NSRect }
+ { "NSRect" NSRect }
+ { "CGRect" NSRect }
+ { "_NSSize" NSSize }
+ { "NSSize" NSSize }
+ { "CGSize" NSSize }
+ { "_NSRange" NSRange }
+ { "NSRange" NSRange }
+} objc>struct-types set-global
+
! The transpose of the above map
SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "NSPoint" "{_NSPoint=ff}" }
- { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
- { "NSSize" "{_NSSize=ff}" }
- { "NSRange" "{_NSRange=II}" }
- { "NSInteger" "i" }
- { "NSUInteger" "I" }
- { "CGFloat" "f" }
+ { NSPoint "{_NSPoint=ff}" }
+ { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+ { NSSize "{_NSSize=ff}" }
+ { NSRange "{_NSRange=II}" }
+ { NSInteger "i" }
+ { NSUInteger "I" }
+ { CGFloat "f" }
} ] }
{ 8 [ H{
- { "NSPoint" "{CGPoint=dd}" }
- { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
- { "NSSize" "{CGSize=dd}" }
- { "NSRange" "{_NSRange=QQ}" }
- { "NSInteger" "q" }
- { "NSUInteger" "Q" }
- { "CGFloat" "d" }
+ { NSPoint "{CGPoint=dd}" }
+ { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+ { NSSize "{CGSize=dd}" }
+ { NSRange "{_NSRange=QQ}" }
+ { NSInteger "q" }
+ { NSUInteger "Q" }
+ { CGFloat "d" }
} ] }
} case
assoc-union alien>objc-types set-global
-: internal-cocoa-type? ( c-type -- ? )
- [ "?" = ] [ first CHAR: _ = ] bi or ;
-
-: warn-c-type ( c-type -- )
- dup internal-cocoa-type?
- [ drop ] [ "Warning: no such C type: " write print ] if ;
-
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
- dup c-types get key? [ warn-c-type "void*" ] unless ;
+ objc>struct-types get at* [ drop void* ] unless ;
ERROR: no-objc-type name ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
- { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: ^ = ] [ 3drop void* ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
- { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: [ = ] [ 3drop void* ] }
[ 2nip decode-type ]
} cond ;
IN: cocoa.subclassing
HELP: define-objc-class
-{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
+{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
{ $list
{ { $link +name+ } " - a string naming the new class. Required." }
: alien-parameters ( params -- seq )
dup parameters>>
- swap return>> large-struct? [ "void*" prefix ] when ;
+ swap return>> large-struct? [ void* prefix ] when ;
: alien-return ( params -- ctype )
- return>> dup large-struct? [ drop "void" ] when ;
+ return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
-: parameter-sizes ( types -- total offsets )
- #! Compute stack frame locations.
+: parameter-offsets ( types -- total offsets )
[
0 [
[ parameter-align drop dup , ] keep stack-size +
M: ##gc compute-stack-frame*
frame-required? on
- stack-frame new swap tagged-values>> length cells >>gc-root-size
+ stack-frame new
+ swap tagged-values>> length cells >>gc-root-size
+ t >>calls-vm?
request-stack-frame ;
M: _spill-area-size compute-stack-frame*
slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
+FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
- [ "int" f "malloc" { "int" } alien-invoke ]
- [ "int" { "int" } "cdecl" alien-indirect ]
- [ "int" { "int" } "cdecl" [ ] alien-callback ]
+ [ int f "malloc" { int } alien-invoke ]
+ [ int { int } "cdecl" alien-indirect ]
+ [ int { int } "cdecl" [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
] when
! Regression. Make sure everything is inlined correctly
-[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
\ No newline at end of file
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
stack-frame new
swap
[ return>> return-size >>return ]
- [ alien-parameters parameter-sizes drop >>params ] bi ;
+ [ alien-parameters parameter-offsets drop >>params ] bi
+ t >>calls-vm? ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien
specialized-arrays ;
-FROM: alien.c-types => heap-size char uchar float double ;
-SPECIALIZED-ARRAYS: float double ;
+FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
+SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
IN: compiler.cfg.intrinsics.simd
MACRO: check-elements ( quots -- )
[ ^^not-vector ]
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
-:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
+:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> swap? :> cc
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
-:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
+:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
rep orig-cc %compare-vector-ccs :> not? :> ccs
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
ccs unclip :> first-cc :> rest-ccs
- src1 src2 rep first-cc (generate-compare-vector) :> first-dst
+ src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst
- [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
+ [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
reduce
not? [ rep generate-not-vector ] when
] if ;
+: sign-bit-mask ( rep -- byte-array )
+ unsign-rep {
+ { char-16-rep [ uchar-array{
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ } underlying>> ] }
+ { short-8-rep [ ushort-array{
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ } underlying>> ] }
+ { int-4-rep [ uint-array{
+ HEX: 8000,0000 HEX: 8000,0000
+ HEX: 8000,0000 HEX: 8000,0000
+ } underlying>> ] }
+ { longlong-2-rep [ ulonglong-array{
+ HEX: 8000,0000,0000,0000
+ HEX: 8000,0000,0000,0000
+ } underlying>> ] }
+ } case ;
+
+:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
+ orig-cc order-cc {
+ { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
+ { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
+ { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
+ { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
+ } case ;
+
+:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
+ {
+ {
+ [ rep orig-cc %compare-vector-reps member? ]
+ [ src1 src2 rep orig-cc (generate-compare-vector) ]
+ }
+ {
+ [ rep %min-vector-reps member? ]
+ [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
+ }
+ {
+ [ rep unsign-rep orig-cc %compare-vector-reps member? ]
+ [
+ rep sign-bit-mask ^^load-constant :> sign-bits
+ src1 sign-bits rep ^^xor-vector
+ src2 sign-bits rep ^^xor-vector
+ rep unsign-rep orig-cc (generate-compare-vector)
+ ]
+ }
+ } cond ;
+
:: generate-unpack-vector-head ( src rep -- dst )
{
{
]
} cond ;
+: generate-min-vector ( src1 src2 rep -- dst )
+ dup %min-vector-reps member?
+ [ ^^min-vector ] [
+ [ cc< generate-compare-vector ]
+ [ generate-blend-vector ] 3bi
+ ] if ;
+
+: generate-max-vector ( src1 src2 rep -- dst )
+ dup %max-vector-reps member?
+ [ ^^max-vector ] [
+ [ cc> generate-compare-vector ]
+ [ generate-blend-vector ] 3bi
+ ] if ;
+
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: layouts namespaces kernel accessors sequences
-classes.algebra locals compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
+USING: layouts namespaces kernel accessors sequences math
+classes.algebra locals combinators cpu.architecture
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
[ [ second literal>> ] [ first value-tag ] bi ] bi*
^^slot-imm ;
+: immediate-slot-offset? ( value-info -- ? )
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
+ [ drop f ]
+ } cond ;
+
: emit-slot ( node -- )
dup node-input-infos
dup first value-tag [
nip
- dup second value-info-small-fixnum?
+ dup second immediate-slot-offset?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
dup node-input-infos
dup second value-tag [
nip
- dup third value-info-small-fixnum?
+ dup third immediate-slot-offset?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ drop emit-primitive ] if ;
{ return integer }
{ total-size integer }
{ gc-root-size integer }
-{ spill-area-size integer } ;
+{ spill-area-size integer }
+{ calls-vm? boolean } ;
! Stack frame utilities
: param-base ( -- n )
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
+ {
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
- 2tri ;
\ No newline at end of file
+ [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
+ } 2cleave ;
\ No newline at end of file
compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite
-: vreg-small-constant? ( vreg -- ? )
+: vreg-immediate-arithmetic? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
[ value>> fixnum? ]
- [ value>> small-enough? ]
+ [ value>> immediate-arithmetic? ]
+ } 1&& ;
+
+: vreg-immediate-bitwise? ( vreg -- ? )
+ vreg>expr {
+ [ constant-expr? ]
+ [ value>> fixnum? ]
+ [ value>> immediate-bitwise? ]
} 1&& ;
! Outputs f to mean no change
M: ##compare-branch rewrite
{
- { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
- { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
{ [ dup self-compare? ] [ rewrite-self-compare-branch ] }
[ drop f ]
} cond ;
M: ##compare rewrite
{
- { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
- { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
{ [ dup self-compare? ] [ rewrite-self-compare ] }
[ drop f ]
} cond ;
M: ##not rewrite
maybe-unary-constant-fold ;
+: arithmetic-op? ( op -- ? )
+ {
+ ##add
+ ##add-imm
+ ##sub
+ ##sub-imm
+ ##mul
+ ##mul-imm
+ } memq? ;
+
+: immediate? ( value op -- ? )
+ arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
+
: reassociate ( insn op -- insn )
[
{
[ ]
} cleave constant-fold*
] dip
- over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
+ 2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
M: ##add-imm rewrite
{
} cond ;
: sub-imm>add-imm ( insn -- insn' )
- [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
+ [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
M: ##sub-imm rewrite
[ swap ] when vreg>constant
] dip new-insn ; inline
+: vreg-immediate? ( vreg op -- ? )
+ arithmetic-op?
+ [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
+
: rewrite-arithmetic ( insn op -- ? )
{
- { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
+ { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
: rewrite-arithmetic-commutative ( insn op -- ? )
{
- { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
- { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
+ { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
+ { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
M: ##xor-vector rewrite
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
+
+: vector-not? ( expr -- ? )
+ {
+ [ not-vector-expr? ]
+ [ {
+ [ xor-vector-expr? ]
+ [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+ } 1&& ]
+ } 1|| ;
+
+GENERIC: vector-not-src ( expr -- vreg )
+M: not-vector-expr vector-not-src src>> vn>vreg ;
+M: xor-vector-expr vector-not-src
+ dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+
+M: ##and-vector rewrite
+ {
+ { [ dup src1>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ { [ dup src2>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src2>> vreg>expr vector-not-src ]
+ [ src1>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ [ drop f ]
+ } cond ;
+
+M: ##andn-vector rewrite
+ dup src1>> vreg>expr vector-not? [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##and-vector new-insn
+ ] [ drop f ] if ;
} value-numbering-step
] unit-test
+! NOT x AND y => x ANDN y
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! x AND NOT y => y ANDN x
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 1 4 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 1 4 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! NOT x ANDN y => x AND y
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! AND <=> ANDN
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ T{ ##and-vector f 6 0 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ T{ ##andn-vector f 6 4 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ T{ ##and-vector f 6 0 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ T{ ##andn-vector f 6 4 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! branch folding
+
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
[ alloc-stack-param ] [ alloc-fastcall-param ] if
[ param-reg ] dip ;
-: (flatten-int-type) ( size -- seq )
- cell /i "void*" c-type <repetition> ;
+: (flatten-int-type) ( type -- seq )
+ stack-size cell align cell /i void* c-type <repetition> ;
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type 1array ;
-
-M: struct-c-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
+M: struct-c-type flatten-value-type (flatten-int-type) ;
+M: long-long-type flatten-value-type (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[
0 [
c-type
- [ parameter-align (flatten-int-type) % ] keep
+ [ parameter-align cell /i void* c-type <repetition> % ] keep
[ stack-size cell align + ] keep
flatten-value-type %
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
- [ [ parameter-sizes nip ] keep ] dip 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
+ [ [ parameter-offsets nip ] keep ] dip 2each ; inline
: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
[ '[ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
+: reverse-each-parameter ( parameters quot -- )
+ [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+
+: prepare-unbox-parameters ( parameters -- offsets types indices )
+ [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
+
: unbox-parameters ( offset node -- )
- parameters>> [
- %prepare-unbox [ over + ] dip unbox-parameter
- ] reverse-each-parameter drop ;
+ parameters>> swap
+ '[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
+ [ length neg %inc-d ]
+ bi ;
: prepare-box-struct ( node -- offset )
#! Return offset on C stack where to store unboxed
] if ;
: stdcall-mangle ( symbol params -- symbol )
- parameters>> parameter-sizes drop number>string "@" glue ;
+ parameters>> parameter-offsets drop number>string "@" glue ;
: alien-invoke-dlsym ( params -- symbols dll )
[ [ function>> dup ] keep stdcall-mangle 2array ]
GENERIC: no-compile? ( word -- ? )
-M: word no-compile? "no-compile" word-prop ;
-
M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+M: word no-compile?
+ {
+ [ macro? ]
+ [ inline? ]
+ [ "special" word-prop ]
+ [ "no-compile" word-prop ]
+ } 1|| ;
+
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
- [
- {
- [ macro? ]
- [ inline? ]
- [ no-compile? ]
- [ "special" word-prop ]
- } 1||
- ] [
- {
- [ do-not-compile? ]
- [ literal-expected? ]
- } 1||
- ] bi* and ;
+ [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
-: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
+: byte-array-offset ( -- n ) 16 byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result )
- "int" { } "cdecl" alien-indirect ;
+ int { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
- "int" { } "cdecl" alien-indirect drop ;
+ int { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
- "int" { "int" "int" } "cdecl" alien-indirect gc ;
+ int { int int } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
unit-test
: indirect-test-3 ( a b c d ptr -- result )
- "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+ int { int int int int } "stdcall" alien-indirect
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
- "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+ int "f-stdcall" "ffi_test_18" { int int int int }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- BAR )
- "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+ BAR "f-stdcall" "ffi_test_19" { long long long }
alien-invoke gc ;
[ 11 6 -7 ] [
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
- "int"
+ int
"f-cdecl" "ffi_test_31"
- { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+ { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
- "float"
+ float
"f-cdecl" "ffi_test_31_point_5"
- { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
+ { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
! Test callbacks
-: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
] unit-test
: callback-4 ( -- callback )
- "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ void { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
] unit-test
: callback-5 ( -- callback )
- "void" { } "cdecl" [ gc ] alien-callback ;
+ void { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5b ( -- callback )
- "void" { } "cdecl" [ compact-gc ] alien-callback ;
+ void { } "cdecl" [ compact-gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5b callback_test_1
] unit-test
: callback-6 ( -- callback )
- "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+ void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
- "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
+ void { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
- "void" { } "cdecl" [
+ void { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback )
- "int" { "int" "int" "int" } "cdecl" [
+ int { int int int } "cdecl" [
+ + 1 +
] alien-callback ;
} cleave ;
: double-rect-callback ( -- alien )
- "void" { "void*" "void*" "double-rect" } "cdecl"
+ void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
- "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
+ void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
] unit-test
: callback-10 ( -- callback )
- "test_struct_14" { "double" "double" } "cdecl"
+ test_struct_14 { double double } "cdecl"
[
test_struct_14 <struct>
swap >>x2
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
- "test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
+ test_struct_14 { double double } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
] unit-test
: callback-11 ( -- callback )
- "test-struct-12" { "int" "double" } "cdecl"
+ test-struct-12 { int double } "cdecl"
[
test-struct-12 <struct>
swap >>x
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
- "test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
+ test-struct-12 { int double } "cdecl" alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
- "test_struct_15" { "float" "float" } "cdecl"
+ test_struct_15 { float float } "cdecl"
[
test_struct_15 <struct>
swap >>y
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
- "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
+ test_struct_15 { float float } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
- "test_struct_16" { "float" "int" } "cdecl"
+ test_struct_16 { float int } "cdecl"
[
test_struct_16 <struct>
swap >>a
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
- "test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
+ test_struct_16 { float int } "cdecl" alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
- [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
- [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+ [ 2 double "libm" "pow" { double double } alien-invoke ]
+ [ -0.5 double "libm" "pow" { double double } alien-invoke ]
if
] if ;
[ 2 0 ] [
1 1
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
-] unit-test
\ No newline at end of file
+] unit-test
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
+[ -16 ] [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
[ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
+[ -1 ] [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
+[ 15 ] [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 2 }
- T{ ##alien-unsigned-1 f 0 0 }
+ T{ ##alien-unsigned-1 f 0 0 0 }
T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
+[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
+
! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
\ No newline at end of file
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
-arrays memory vocabs parser eval ;
+arrays memory vocabs parser eval quotations compiler.errors
+definitions ;
IN: compiler.tests.simple
! Test empty word
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test
] times
+
+! This should not compile
+GENERIC: bad-effect-test ( a -- )
+M: quotation bad-effect-test call ; inline
+: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
+
+[ bad-effect-test* ] [ not-compiled? ] must-fail-with
+
+! Don't want compiler error to stick around
+[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
-
-: value-info-small-fixnum? ( value-info -- ? )
- literal>> {
- { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
- [ drop f ]
- } cond ;
-
-: value-info-small-tagged? ( value-info -- ? )
- dup literal?>> [
- literal>> {
- { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
- { [ dup not ] [ drop t ] }
- [ drop f ]
- } cond
- ] [ drop f ] if ;
'[ _ _ 2bi ] "outputs" set-word-prop
] each
-\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
-\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+: shift-op-class ( info1 info2 -- newclass )
+ [ class>> ] bi@
+ 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
+
+: shift-op ( word interval-quot post-proc-quot -- )
+ '[
+ [ shift-op-class ] [ _ binary-op-interval ] 2bi
+ @
+ <class/interval-info>
+ ] "outputs" set-word-prop ;
+
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
+] unit-test
+
cell-bits 32 = [
[ V{ integer } ] [
[ { fixnum } declare 1 swap 31 bitand shift ]
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
+! bitand identities
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
+
+[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
+
+! Could be bignum not integer but who cares
+[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
: positive-fixnum? ( obj -- ? )
{ [ fixnum? ] [ 0 >= ] } 1&& ;
-: simplify-bitand? ( value -- ? )
- value-info literal>> positive-fixnum? ;
+: simplify-bitand? ( value1 value2 -- ? )
+ [ literal>> positive-fixnum? ]
+ [ class>> fixnum swap class<= ]
+ bi* and ;
-: all-ones? ( int -- ? )
- dup 1 + bitand zero? ; inline
+: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
-: redundant-bitand? ( var 111... -- ? )
- [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
+: redundant-bitand? ( value1 value2 -- ? )
+ [ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip all-ones? ]
[ 0 swap [a,b] interval-subset? ]
} 2&& ;
-: (zero-bitand?) ( value-info value-info' -- ? )
+: zero-bitand? ( value1 value2 -- ? )
[ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip bitnot all-ones? ]
[ 0 swap bitnot [a,b] interval-subset? ]
} 2&& ;
-: zero-bitand? ( var1 var2 -- ? )
- [ value-info ] bi@
- { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
-
{
bitand-integer-integer
bitand-integer-fixnum
bitand
} [
[
- {
+ in-d>> first2 [ value-info ] bi@ {
{
- [ dup in-d>> first2 zero-bitand? ]
- [ drop [ 2drop 0 ] ]
+ [ 2dup zero-bitand? ]
+ [ 2drop [ 2drop 0 ] ]
}
{
- [ dup in-d>> first2 redundant-bitand? ]
- [ drop [ drop ] ]
+ [ 2dup swap zero-bitand? ]
+ [ 2drop [ 2drop 0 ] ]
}
{
- [ dup in-d>> first2 swap redundant-bitand? ]
- [ drop [ nip ] ]
+ [ 2dup redundant-bitand? ]
+ [ 2drop [ drop ] ]
}
{
- [ dup in-d>> first simplify-bitand? ]
- [ drop [ >fixnum fixnum-bitand ] ]
+ [ 2dup swap redundant-bitand? ]
+ [ 2drop [ nip ] ]
}
{
- [ dup in-d>> second simplify-bitand? ]
- [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
+ [ 2dup simplify-bitand? ]
+ [ 2drop [ >fixnum fixnum-bitand ] ]
}
- [ drop f ]
+ {
+ [ 2dup swap simplify-bitand? ]
+ [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
+ }
+ [ 2drop f ]
} cond
] "custom-inlining" set-word-prop
] each
! Speeds up 2^
+: 2^? ( #call -- ? )
+ in-d>> first2 [ value-info ] bi@
+ [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
+ [ class>> fixnum class<= ]
+ bi* and ;
+
\ shift [
- in-d>> first value-info literal>> 1 = [
+ 2^? [
cell-bits tag-bits get - 1 -
'[
>fixnum dup 0 < [ 2drop 0 ] [
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;\r
\r
HELP: block-unless-pred\r
-{ $values { "pred" { $quotation "( obj -- ? )" } } \r
+{ $values\r
{ "mailbox" mailbox }\r
{ "timeout" "a " { $link duration } " or " { $link f } }\r
+ { "pred" { $quotation "( obj -- ? )" } } \r
}\r
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;\r
\r
{ release void* }
{ copyDescription void* } ;
-! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
-TYPEDEF: void* FSEventStreamCallback
+! callback(
+CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
[ fds>> [ enable-all-callbacks ] each ] bi ;
: timer-callback ( -- callback )
- "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
+ void { CFRunLoopTimerRef void* } "cdecl"
[ 2drop reset-run-loop yield ] alien-callback ;
: init-thread-timer ( -- )
M: stack-params param-reg drop ;
-! Is this integer small enough to appear in value template
-! slots?
-HOOK: small-enough? cpu ( n -- ? )
+! Is this integer small enough to be an immediate operand for
+! %add-imm, %sub-imm, and %mul-imm?
+HOOK: immediate-arithmetic? cpu ( n -- ? )
+
+! Is this integer small enough to be an immediate operand for
+! %and-imm, %or-imm, and %xor-imm?
+HOOK: immediate-bitwise? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
-HOOK: %prepare-unbox cpu ( -- )
+HOOK: %prepare-unbox cpu ( n -- )
HOOK: %unbox cpu ( n rep func -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
- scratch-reg allot-ptr n 8 align ADDI
+ scratch-reg allot-ptr n data-alignment get align ADDI
scratch-reg nursery-ptr 0 STW ;
:: store-header ( dst class -- )
M:: ppc %load-param-reg ( stack reg rep -- )
reg stack local@ rep load-from-frame ;
-M: ppc %prepare-unbox ( -- )
- ! First parameter is top of stack
- 3 ds-reg 0 LWZ
- ds-reg dup cell SUBI ;
+M: ppc %prepare-unbox ( n -- )
+ [ 3 ] dip <ds-loc> loc>operand LWZ ;
M: ppc %unbox ( n rep func -- )
! Value must be in r3
! Unbox former top of data stack to return registers
unbox-return ;
-M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
+
+M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg ECX ;
+: local@ ( n -- op )
+ stack-frame get extra-stack-space dup 16 assert= + stack@ ;
+
+M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
+
M: x86.32 %mark-card
drop HEX: ffffffff [+] card-mark <byte> MOV
building get pop
M: x86.32 pic-tail-reg EBX ;
-M: x86.32 reserved-area-size 0 ;
+M: x86.32 reserved-stack-space 4 cells ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
-: push-vm-ptr ( -- )
- 0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
+: save-vm-ptr ( n -- )
+ stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
and or ;
: struct-return@ ( n -- operand )
- [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+ [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: float-regs param-regs drop { } ;
-GENERIC: push-return-reg ( rep -- )
-GENERIC: load-return-reg ( n rep -- )
-GENERIC: store-return-reg ( n rep -- )
-
-M: int-rep push-return-reg drop EAX PUSH ;
-M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
-M: int-rep store-return-reg drop stack@ EAX MOV ;
-
-M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
-M: float-rep load-return-reg drop next-stack@ FLDS ;
-M: float-rep store-return-reg drop stack@ FSTPS ;
+GENERIC: load-return-reg ( src rep -- )
+GENERIC: store-return-reg ( dst rep -- )
-M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
-M: double-rep load-return-reg drop next-stack@ FLDL ;
-M: double-rep store-return-reg drop stack@ FSTPL ;
+M: int-rep load-return-reg drop EAX swap MOV ;
+M: int-rep store-return-reg drop EAX MOV ;
-: align-sub ( n -- )
- [ align-stack ] keep - decr-stack-reg ;
+M: float-rep load-return-reg drop FLDS ;
+M: float-rep store-return-reg drop FSTPS ;
-: align-add ( n -- )
- align-stack incr-stack-reg ;
-
-: with-aligned-stack ( n quot -- )
- '[ align-sub @ ] [ align-add ] bi ; inline
+M: double-rep load-return-reg drop FLDL ;
+M: double-rep store-return-reg drop FSTPL ;
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
3 cells - decr-stack-reg ;
-M: x86.32 %load-param-reg 3drop ;
+M: x86.32 %load-param-reg
+ stack-params assert=
+ [ [ EAX ] dip local@ MOV ] dip
+ stack@ EAX MOV ;
M: x86.32 %save-param-reg 3drop ;
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
- over [ load-return-reg ] [ 2drop ] if ;
+ over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( n rep func -- )
n rep (%box)
- rep rep-size cell + [
- push-vm-ptr
- rep push-return-reg
- func f %alien-invoke
- ] with-aligned-stack ;
-
+ rep rep-size save-vm-ptr
+ 0 stack@ rep store-return-reg
+ func f %alien-invoke ;
+
: (%box-long-long) ( n -- )
[
EDX over next-stack@ MOV
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
- 12 [
- push-vm-ptr
- EDX PUSH
- EAX PUSH
- f %alien-invoke
- ] with-aligned-stack ;
+ 8 save-vm-ptr
+ 4 stack@ EDX MOV
+ 0 stack@ EAX MOV
+ f %alien-invoke ;
M:: x86.32 %box-large-struct ( n c-type -- )
- ! Compute destination address
EDX n struct-return@ LEA
- 12 [
- push-vm-ptr
- ! Push struct size
- c-type heap-size PUSH
- ! Push destination address
- EDX PUSH
- ! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke
- ] with-aligned-stack ;
+ 8 save-vm-ptr
+ 4 stack@ c-type heap-size MOV
+ 0 stack@ EDX MOV
+ "box_value_struct" f %alien-invoke ;
M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
EAX f struct-return@ LEA
! Store it as the first parameter
- 0 stack@ EAX MOV ;
+ 0 local@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 16 [
- push-vm-ptr
- heap-size PUSH
- EDX PUSH
- EAX PUSH
- "box_small_struct" f %alien-invoke
- ] with-aligned-stack ;
+ 12 save-vm-ptr
+ 8 stack@ swap heap-size MOV
+ 4 stack@ EDX MOV
+ 0 stack@ EAX MOV
+ "box_small_struct" f %alien-invoke ;
M: x86.32 %prepare-unbox ( -- )
- #! Move top of data stack to EAX.
- EAX ESI [] MOV
- ESI 4 SUB ;
+ EAX swap ds-reg reg-stack MOV ;
: call-unbox-func ( func -- )
- 8 [
- ! push the vm ptr as an argument
- push-vm-ptr
- ! Push parameter
- EAX PUSH
- ! Call the unboxer
- f %alien-invoke
- ] with-aligned-stack ;
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ f %alien-invoke ;
M: x86.32 %unbox ( n rep func -- )
#! The value being unboxed must already be in EAX.
#! a parameter to a C function about to be called.
call-unbox-func
! Store the return value on the C stack
- over [ store-return-reg ] [ 2drop ] if ;
+ over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
call-unbox-func
! Store the return value on the C stack
[
- dup stack@ EAX MOV
- cell + stack@ EDX MOV
+ [ local@ EAX MOV ]
+ [ 4 + local@ EDX MOV ] bi
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
- 8 [
- push-vm-ptr
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ "alien_offset" f %alien-invoke
+ ! Load first cell
+ EAX EAX [] MOV ;
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
- 8 [
- push-vm-ptr
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ "alien_offset" f %alien-invoke
+ ! Load second cell
+ EDX EAX 4 [+] MOV
+ ! Load first cell
+ EAX EAX [] MOV ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- EDX n stack@ LEA
- 16 [
- push-vm-ptr
- ! Push struct size
- c-type heap-size PUSH
- ! Push destination address
- EDX PUSH
- ! Push source address
- EAX PUSH
- ! Copy the struct to the stack
- "to_value_struct" f %alien-invoke
- ] with-aligned-stack ;
+ EDX n local@ LEA
+ 12 save-vm-ptr
+ 8 stack@ c-type heap-size MOV
+ 4 stack@ EDX MOV
+ 0 stack@ EAX MOV
+ "to_value_struct" f %alien-invoke ;
M: x86.32 %nest-stacks ( -- )
! Save current frame. See comment in vm/contexts.hpp
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
- 8 [
- push-vm-ptr
- EAX PUSH
- "nest_stacks" f %alien-invoke
- ] with-aligned-stack ;
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ "nest_stacks" f %alien-invoke ;
M: x86.32 %unnest-stacks ( -- )
- 4 [
- push-vm-ptr
- "unnest_stacks" f %alien-invoke
- ] with-aligned-stack ;
+ 0 save-vm-ptr
+ "unnest_stacks" f %alien-invoke ;
M: x86.32 %prepare-alien-indirect ( -- )
- 4 [
- push-vm-ptr
- "unbox_alien" f %alien-invoke
- ] with-aligned-stack
+ 0 save-vm-ptr
+ "unbox_alien" f %alien-invoke
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
+ ! Fastcall
param-reg-1 swap %load-reference
param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
M: x86.32 %callback-value ( ctype -- )
- ! Align C stack
- ESP 12 SUB
- ! Save top of data stack in non-volatile register
- %prepare-unbox
- EAX PUSH
- push-vm-ptr
+ 0 %prepare-unbox
+ 4 stack@ EAX MOV
+ 0 save-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
- ! Place top of data stack in EAX
- temp-reg POP
- EAX POP
- ! Restore C stack
- ESP 12 ADD
+ ! Place former top of data stack back in EAX
+ EAX 4 stack@ MOV
! Unbox EAX
unbox-return ;
} cond RET ;
M:: x86.32 %call-gc ( gc-root-count temp -- )
- temp gc-root-base param@ LEA
- 12 [
- ! Pass the VM ptr as the third parameter
- push-vm-ptr
- ! Pass number of roots as second parameter
- gc-root-count PUSH
- ! Pass pointer to start of GC roots as first parameter
- temp PUSH
- ! Call GC
- "inline_gc" f %alien-invoke
- ] with-aligned-stack ;
+ temp gc-root-base special@ LEA
+ 8 save-vm-ptr
+ 4 stack@ gc-root-count MOV
+ 0 stack@ temp MOV
+ "inline_gc" f %alien-invoke ;
M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-fp-params? f ;
+! Dreadful
+M: object flatten-value-type (flatten-int-type) ;
+
os windows? [
- cell "longlong" c-type (>>align)
- cell "ulonglong" c-type (>>align)
- 4 "double" c-type (>>align)
+ cell longlong c-type (>>align)
+ cell ulonglong c-type (>>align)
+ 4 double c-type (>>align)
] unless
check-sse
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
IN: cpu.x86.64
+: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
+: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
+: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
+: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
+
+M: x86.64 pic-tail-reg RBX ;
+
+M: int-regs return-reg drop RAX ;
+M: float-regs return-reg drop XMM0 ;
+
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+
+M: x86.64 extra-stack-space drop 0 ;
+
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
} }
} ;
-M: x86.64 ds-reg R14 ;
-M: x86.64 rs-reg R15 ;
-M: x86.64 stack-reg RSP ;
+: param@ ( n -- op ) reserved-stack-space + stack@ ;
+
+M: x86.64 %prologue ( n -- )
+ temp-reg 0 MOV rc-absolute-cell rel-this
+ dup PUSH
+ temp-reg PUSH
+ stack-reg swap 3 cells - SUB ;
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
[ align-code ]
bi ;
-: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
-: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
-: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
-: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
-
-M: x86.64 pic-tail-reg RBX ;
-
-M: int-regs return-reg drop RAX ;
-M: float-regs return-reg drop XMM0 ;
-
-M: x86.64 %prologue ( n -- )
- temp-reg 0 MOV rc-absolute-cell rel-this
- dup PUSH
- temp-reg PUSH
- stack-reg swap 3 cells - SUB ;
-
M: stack-params copy-register*
drop
{
call
] with-scope ; inline
-M: x86.64 %prepare-unbox ( -- )
- ! First parameter is top of stack
- param-reg-1 R14 [] MOV
- R14 cell SUB ;
+M: x86.64 %prepare-unbox ( n -- )
+ param-reg-1 swap ds-reg reg-stack MOV ;
M:: x86.64 %unbox ( n rep func -- )
param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
- ! Save top of data stack
- %prepare-unbox
- ! Save top of data stack
+ 0 %prepare-unbox
RSP 8 SUB
param-reg-1 PUSH
param-reg-1 %mov-vm-ptr
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: x86.64 reserved-area-size 0 ;
+M: x86.64 reserved-stack-space 0 ;
SYMBOL: (stack-value)
! The ABI for passing structs by value is pretty great
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
-M: x86.64 reserved-area-size 4 cells ;
+M: x86.64 reserved-stack-space 4 cells ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size { 1 2 4 8 } member? ;
HOOK: stack-reg cpu ( -- reg )
-HOOK: reserved-area-size cpu ( -- n )
+HOOK: reserved-stack-space cpu ( -- n )
+
+HOOK: extra-stack-space cpu ( stack-frame -- n )
: stack@ ( n -- op ) stack-reg swap [+] ;
-: param@ ( n -- op ) reserved-area-size + stack@ ;
+: special@ ( n -- op )
+ stack-frame get extra-stack-space +
+ reserved-stack-space +
+ stack@ ;
-: spill@ ( n -- op ) spill-offset param@ ;
+: spill@ ( n -- op ) spill-offset special@ ;
-: gc-root@ ( n -- op ) gc-root-offset param@ ;
+: gc-root@ ( n -- op ) gc-root-offset special@ ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( stack-frame -- i )
- (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
+ [ (stack-frame-size) ]
+ [ extra-stack-space ] bi +
+ reserved-stack-space +
+ 3 cells +
+ align-stack ;
! Must be a volatile register not used for parameter passing, for safe
! use in calls in and out of C
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
- [ [] ] dip 8 align ADD ;
+ [ [] ] dip data-alignment get align ADD ;
: store-header ( temp class -- )
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
- { sse4.1? { longlong-2-rep } }
+ { sse4.2? { longlong-2-rep } }
} available-reps ;
M: x86 %compare-vector-reps
{
- { [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] }
+ { [ dup { cc= cc/= cc/<>= cc<>= } memq? ] [ drop %compare-vector-eq-reps ] }
[ drop %compare-vector-ord-reps ]
} cond ;
M: x86 %min-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %max-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 value-struct? drop t ;
-M: x86 small-enough? ( n -- ? )
+M: x86 immediate-arithmetic? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
+
+M: x86 immediate-bitwise? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: next-stack@ ( n -- operand )
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
-TYPEDEF: void sqlite3
-TYPEDEF: void sqlite3_stmt
+TYPEDEF: void* sqlite3*
+TYPEDEF: void* sqlite3_stmt*
TYPEDEF: longlong sqlite3_int64
TYPEDEF: ulonglong sqlite3_uint64
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
- "int" "sqlite" "sqlite3_bind_int64"
- { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
+ int "sqlite" "sqlite3_bind_int64"
+ { sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-column-uint64 ( pStmt col -- uint64 )
- "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
- { "sqlite3_stmt*" "int" } alien-invoke ;
+ sqlite3_uint64 "sqlite" "sqlite3_column_int64"
+ { sqlite3_stmt* int } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
compiler.units generic.standard generic.single vocabs init
kernel.private io.encodings accessors math.order destructors
source-files parser classes.tuple.parser effects.parser lexer
-generic.parser strings.parser vocabs.loader vocabs.parser see
+generic.parser strings.parser vocabs.loader vocabs.parser
source-files.errors ;
IN: debugger
-GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
-M: object error. . ;
-
M: object error-help drop f ;
M: tuple error-help class ;
+M: source-file-error error-help error>> error-help ;
+
+GENERIC: error. ( error -- )
+
+M: object error. . ;
+
M: string error. print ;
: :s ( -- )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger io prettyprint sequences system ;
+USING: assocs debugger io kernel literals math.parser namespaces
+prettyprint sequences system windows.kernel32 ;
IN: debugger.windows
-M: windows signal-error. "Windows exception #" write third .h ;
\ No newline at end of file
+CONSTANT: seh-names
+ H{
+ { $ STATUS_GUARD_PAGE_VIOLATION "STATUS_GUARD_PAGE_VIOLATION" }
+ { $ STATUS_DATATYPE_MISALIGNMENT "STATUS_DATATYPE_MISALIGNMENT" }
+ { $ STATUS_BREAKPOINT "STATUS_BREAKPOINT" }
+ { $ STATUS_SINGLE_STEP "STATUS_SINGLE_STEP" }
+ { $ STATUS_ACCESS_VIOLATION "STATUS_ACCESS_VIOLATION" }
+ { $ STATUS_IN_PAGE_ERROR "STATUS_IN_PAGE_ERROR" }
+ { $ STATUS_INVALID_HANDLE "STATUS_INVALID_HANDLE" }
+ { $ STATUS_NO_MEMORY "STATUS_NO_MEMORY" }
+ { $ STATUS_ILLEGAL_INSTRUCTION "STATUS_ILLEGAL_INSTRUCTION" }
+ { $ STATUS_NONCONTINUABLE_EXCEPTION "STATUS_NONCONTINUABLE_EXCEPTION" }
+ { $ STATUS_INVALID_DISPOSITION "STATUS_INVALID_DISPOSITION" }
+ { $ STATUS_ARRAY_BOUNDS_EXCEEDED "STATUS_ARRAY_BOUNDS_EXCEEDED" }
+ { $ STATUS_FLOAT_DENORMAL_OPERAND "STATUS_FLOAT_DENORMAL_OPERAND" }
+ { $ STATUS_FLOAT_DIVIDE_BY_ZERO "STATUS_FLOAT_DIVIDE_BY_ZERO" }
+ { $ STATUS_FLOAT_INEXACT_RESULT "STATUS_FLOAT_INEXACT_RESULT" }
+ { $ STATUS_FLOAT_INVALID_OPERATION "STATUS_FLOAT_INVALID_OPERATION" }
+ { $ STATUS_FLOAT_OVERFLOW "STATUS_FLOAT_OVERFLOW" }
+ { $ STATUS_FLOAT_STACK_CHECK "STATUS_FLOAT_STACK_CHECK" }
+ { $ STATUS_FLOAT_UNDERFLOW "STATUS_FLOAT_UNDERFLOW" }
+ { $ STATUS_INTEGER_DIVIDE_BY_ZERO "STATUS_INTEGER_DIVIDE_BY_ZERO" }
+ { $ STATUS_INTEGER_OVERFLOW "STATUS_INTEGER_OVERFLOW" }
+ { $ STATUS_PRIVILEGED_INSTRUCTION "STATUS_PRIVILEGED_INSTRUCTION" }
+ { $ STATUS_STACK_OVERFLOW "STATUS_STACK_OVERFLOW" }
+ { $ STATUS_CONTROL_C_EXIT "STATUS_CONTROL_C_EXIT" }
+ { $ STATUS_FLOAT_MULTIPLE_FAULTS "STATUS_FLOAT_MULTIPLE_FAULTS" }
+ { $ STATUS_FLOAT_MULTIPLE_TRAPS "STATUS_FLOAT_MULTIPLE_TRAPS" }
+ }
+
+: seh-name. ( n -- )
+ seh-names at [ " (" ")" surround write ] when* ;
+
+M: windows signal-error.
+ "Windows exception 0x" write
+ third [ >hex write ] [ seh-name. ] bi nl ;
IN: delegate
HELP: define-protocol
-{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
+{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } }
{ $description "Defines a symbol as a protocol." }
{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
{ $description "Adds an integer to the line number of a line/column pair." } ;
HELP: =col
-{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
+{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the column number of a line/column pair." } ;
HELP: =line
-{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
+{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the line number of a line/column pair." } ;
HELP: lines-equal?
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting parser parser.notes compiler.units kernel namespaces
-debugger io.streams.string fry combinators effects.parser ;
+USING: splitting parser parser.notes compiler.units kernel
+namespaces debugger io.streams.string fry combinators
+effects.parser continuations ;
IN: eval
: parse-string ( str -- quot )
[
"quiet" on
parser-notes off
- '[ _ (( -- )) (eval) ] try
+ '[ _ (( -- )) (eval) ] [ print-error ] recover
] with-string-writer ;
: eval>string ( str -- output )
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
HELP: uchange
-{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
+{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } }
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
HELP: uget
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
\r
-HELP: neach\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }\r
-{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;\r
-\r
-HELP: nmap\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }\r
-{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;\r
-\r
-HELP: nmap-as\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }\r
-{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;\r
-\r
-HELP: mnmap\r
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }\r
-{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;\r
-\r
-HELP: mnmap-as\r
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } }\r
-{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;\r
-\r
HELP: mnswap\r
{ $values { "m" integer } { "n" integer } }\r
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\r
apply-curry\r
cleave-curry\r
spread-curry\r
- neach\r
- nmap\r
- nmap-as\r
- mnmap\r
- mnmap-as\r
} ;\r
\r
ARTICLE: "other-generalizations" "Additional generalizations"\r
"shuffle-generalizations"\r
"combinator-generalizations"\r
"other-generalizations"\r
-} ;\r
+}\r
+"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;\r
\r
ABOUT: "generalizations"\r
\r
[ '[ number>string _ append ] 4 napply ] must-infer\r
\r
-: neach-test ( a b c d -- )\r
- [ 4 nappend print ] 4 neach ;\r
-: nmap-test ( a b c d -- e )\r
- [ 4 nappend ] 4 nmap ;\r
-: nmap-as-test ( a b c d -- e )\r
- [ 4 nappend ] [ ] 4 nmap-as ;\r
-: mnmap-3-test ( a b c d -- e f g )\r
- [ append ] 4 3 mnmap ;\r
-: mnmap-2-test ( a b c d -- e f )\r
- [ [ append ] 2bi@ ] 4 2 mnmap ;\r
-: mnmap-as-test ( a b c d -- e f )\r
- [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;\r
-: mnmap-1-test ( a b c d -- e )\r
- [ 4 nappend ] 4 1 mnmap ;\r
-: mnmap-0-test ( a b c d -- )\r
- [ 4 nappend print ] 4 0 mnmap ;\r
-\r
-[ """A1a!\r
-B2b@\r
-C3c#\r
-D4d$\r
-""" ] [\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- [ neach-test ] with-string-writer\r
-] unit-test\r
-\r
-[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- nmap-test\r
-] unit-test\r
-\r
-[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- nmap-as-test\r
-] unit-test\r
-\r
-[\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a!" "b@" "c#" "d$" }\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-3-test\r
-] unit-test\r
-\r
-[\r
- { "A1" "B2" "C3" "D4" }\r
- { "a!" "b@" "c#" "d$" }\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-2-test\r
-] unit-test\r
-\r
-[\r
- { "A1" "B2" "C3" "D4" }\r
- [ "a!" "b@" "c#" "d$" ]\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-as-test\r
-] unit-test\r
-\r
-[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-1-test\r
-] unit-test\r
-\r
-[ """A1a!\r
-B2b@\r
-C3c#\r
-D4d$\r
-""" ] [\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- [ mnmap-0-test ] with-string-writer\r
-] unit-test\r
-\r
[ 6 8 10 12 ] [\r
1 2 3 4\r
5 6 7 8 [ + ] 4 apply-curry 4 spread*\r
MACRO: nspin ( n -- )
[ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
-MACRO: nmin-length ( n -- )
- dup 1 - [ min ] n*quot
- '[ [ length ] _ napply @ ] ;
-
-: nnth-unsafe ( n ...seq n -- )
- [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
-MACRO: nset-nth-unsafe ( n -- )
- [ [ drop ] ]
- [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
- if-zero ;
-
-: (neach) ( ...seq quot n -- len quot' )
- dup dup dup
- '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-
-: neach ( ...seq quot n -- )
- (neach) each-integer ; inline
-
-: nmap-as ( ...seq quot exemplar n -- result )
- '[ _ (neach) ] dip map-integers ; inline
-
-: nmap ( ...seq quot n -- result )
- dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
-
-MACRO: nnew-sequence ( n -- )
- [ [ drop ] ]
- [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-
-: nnew-like ( len ...exemplar quot n -- result... )
- dup dup dup dup '[
- _ nover
- [ [ _ nnew-sequence ] dip call ]
- _ ndip [ like ]
- _ apply-curry
- _ spread*
- ] call ; inline
-
-MACRO: (ncollect) ( n -- )
- dup dup 1 +
- '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
-
-: ncollect ( len quot ...into n -- )
- (ncollect) each-integer ; inline
-
-: nmap-integers ( len quot ...exemplar n -- result... )
- dup dup dup
- '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
-
-: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
- dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
-
-: mnmap ( m*seq quot m n -- result*n )
- 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-
USING: grouping tools.test kernel sequences arrays
-math ;
+math accessors ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
>array
] unit-test
+[ 0 ] [ { } 2 <clumps> length ] unit-test
+[ 0 ] [ { 1 } 2 <clumps> length ] unit-test
+[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
+[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
+
+[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
+[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
+[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
+
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1 + ; inline
+ [ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps set-length
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
-{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
+{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
-{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
+{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
{ $side-effects "heap" } ;
HELP: heap-peek
-{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
{ $side-effects "heap" } ;
HELP: heap-pop
-{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
-io.streams.string continuations debugger compiler.units eval ;
+io.streams.string continuations debugger compiler.units eval
+help.syntax ;
IN: help.crossref.tests
[ ] [
] unit-test
[ "xxx" ] [ "yyy" article-parent ] unit-test
+
+ARTICLE: "crossref-test-1" "Crossref test 1"
+"Hello world" ;
+
+ARTICLE: "crossref-test-2" "Crossref test 2"
+{ $markup-example { $subsection "crossref-test-1" } } ;
+
+[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
[ ] [ "error-index" print-topic ] unit-test
-[ ] [ "type-index" print-topic ] unit-test
[ ] [ "class-index" print-topic ] unit-test
ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ;
-ARTICLE: "type-index" "Type index"
-{ $index [ builtins get sift ] } ;
-
ARTICLE: "class-index" "Class index"
{ $heading "Built-in classes" }
{ $index [ classes [ builtin-class? ] filter ] }
"article-index"
"primitive-index"
"error-index"
- "type-index"
"class-index"
}
{ $heading "Explore the code base" }
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
- first rest [ first ] map prune natural-sort
+ first rest [ first ] map prune
] unless ;
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map
- prune natural-sort ;
+ [ dup pair? [ first ] when effect>string ] map prune ;
: contains-funky-elements? ( element -- ? )
{
M: object elements* 2drop ;
M: array elements*
- [ [ elements* ] with each ] 2keep
- [ first eq? ] keep swap [ , ] [ drop ] if ;
+ [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
+ [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
$nl
"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
{ $code "USE: palindrome" }
-"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
+"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload, in case the refresh feature does not pick up changes from disk:"
{ $code "\"palindrome\" reload" }
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl
-USING: help.vocabs tools.test help.markup help vocabs ;
+USING: help.vocabs tools.test help.markup help vocabs io ;
IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test
+[ ] [ nl ] unit-test
io.encodings.binary io.encodings.string io.files
io.streams.limited kernel locals macros math math.bitwise
math.functions namespaces sequences specialized-arrays
-specialized-arrays.instances.uint
-specialized-arrays.instances.ushort strings summary ;
+strings summary ;
+SPECIALIZED-ARRAYS: uint ushort ;
IN: images.bitmap
SINGLETON: bmp-image
USING: kernel arrays namespaces math accessors alien locals
destructors system threads io.backend.unix.multiplexers
io.backend.unix.multiplexers.kqueue core-foundation
-core-foundation.run-loop ;
+core-foundation.run-loop core-foundation.file-descriptors ;
+FROM: alien.c-types => void void* ;
IN: io.backend.unix.multiplexers.run-loop
TUPLE: run-loop-mx kqueue-mx ;
: file-descriptor-callback ( -- callback )
- "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
+ void { CFFileDescriptorRef CFOptionFlags void* }
"cdecl" [
3drop
0 mx get kqueue-mx>> wait-for-events
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
{ $subsections <mapped-array> }
"Additionally, files may be opened with two combinators which take a c-type as input:"
-{ $subsections with-mapped-array }
-{ $subsections with-mapped-array-reader }
+{ $subsections with-mapped-array with-mapped-array-reader }
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
$nl
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
{ $subsections <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
"Utility combinators which wrap the above:"
-{ $subsections with-mapped-file }
-{ $subsections with-mapped-file-reader }
-{ $subsections with-mapped-array }
-{ $subsections with-mapped-array-reader }
+{ $subsections with-mapped-file
+ with-mapped-file-reader
+ with-mapped-array
+ with-mapped-array-reader }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsections
"io.mmap.arrays"
USING: alien.c-types alien.data compiler.tree.debugger
continuations io.directories io.encodings.ascii io.files
io.files.temp io.mmap kernel math sequences sequences.private
-specialized-arrays specialized-arrays.instances.uint tools.test ;
+specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: uint
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
] with-destructors ;
+SYMBOL: bind-local-address
+
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
M: inet (server)
invalid-inet-server ;
+ERROR: invalid-local-address addrspec ;
+
+M: invalid-local-address summary
+ drop "Cannot use with-local-address with <inet>; use <inet4> or <inet6> instead" ;
+
+: with-local-address ( addr quot -- )
+ [
+ [ ] [ inet4? ] [ inet6? ] tri or
+ [ bind-local-address ]
+ [ invalid-local-address ] if
+ ] dip with-variable ; inline
+
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] }
[ (io-error) ]
} cond ;
+: ?bind-client ( socket -- )
+ bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
+
M: object ((client)) ( addrspec -- fd )
- protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
+ protocol-family SOCK_STREAM socket-fd
+ [ init-client-socket ] [ ?bind-client ] [ ] tri ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors io.sockets io.sockets.private\r
io.backend.windows io.backend windows.winsock system destructors\r
alien.c-types classes.struct combinators ;\r
+FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
M: windows addrinfo-error ( n -- )\r
\r
M: object ((client)) ( addrspec -- handle )\r
[ SOCK_STREAM open-socket ] keep\r
- [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+ [\r
+ bind-local-address get\r
+ [ nip make-sockaddr/size ]\r
+ [ unspecific-sockaddr/size ] if* bind-socket\r
+ ] [ drop ] 2bi ;\r
\r
: server-socket ( addrspec type -- fd )\r
[ open-socket ] [ drop ] 2bi\r
{ $description "Put the head and tail of the list on the stack." } ;
HELP: unswons
-{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
+{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
{ leach foldl lmap>array } related-words
{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log a message every time it is called." } ;
HELP: add-input-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-output-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-error-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values and any errors it throws."
$nl
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
{ cis exp } related-words
HELP: polar>
-{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } }
+{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } }
{ $description "Converts an absolute value and argument (polar form) to a complex number." } ;
HELP: [-1,1]?
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
-<PRIVATE
-
-: x ( seq -- elt ) first ; inline
-: y ( seq -- elt ) second ; inline
-: z ( seq -- elt ) third ; inline
-
-: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
-
-PRIVATE>
-
-: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
+: cross ( vec1 vec2 -- vec3 )
+ [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
+ [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
HELP: unique-primes
{ $values
- { "numbits" integer } { "n" integer }
+ { "n" integer }
+ { "numbits" integer }
{ "seq" sequence }
}
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
} >>special-wrappers
{
{ { +vector+ +vector+ -> +vector+ } A-vv->v-op }
+ { { +vector+ +any-vector+ -> +vector+ } A-vv->v-op }
{ { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
{ { +vector+ +literal+ -> +vector+ } A-vn->v-op }
{ { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
{ \ (simd-v*) [ %mul-vector-reps ] }
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] }
{ \ (simd-v/) [ %div-vector-reps ] }
- { \ (simd-vmin) [ %min-vector-reps ] }
- { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] }
+ { \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] }
{ \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
{ \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] }
{ \ (simd-(vunpack-head)) [ (%unpack-reps) ] }
{ \ (simd-(vunpack-tail)) [ (%unpack-reps) ] }
- { \ (simd-v<=) [ cc<= %compare-vector-reps ] }
- { \ (simd-v<) [ cc< %compare-vector-reps ] }
- { \ (simd-v=) [ cc= %compare-vector-reps ] }
- { \ (simd-v>) [ cc> %compare-vector-reps ] }
- { \ (simd-v>=) [ cc>= %compare-vector-reps ] }
- { \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
+ { \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] }
+ { \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] }
+ { \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] }
+ { \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] }
+ { \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] }
+ { \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
{ \ (simd-vany?) [ %test-vector-reps ] }
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects sets kernel.private
accessors combinators math math.intervals math.vectors
-math.vectors.conversion.backend
-namespaces assocs fry splitting classes.algebra generalizations
-locals compiler.tree.propagation.info ;
+math.vectors.conversion.backend namespaces assocs fry splitting
+classes.algebra generalizations locals
+compiler.tree.propagation.info ;
IN: math.vectors.specialization
-SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
+SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
+
+: parent-vector-class ( type -- type' )
+ {
+ { [ dup simd-128 class<= ] [ drop simd-128 ] }
+ { [ dup simd-256 class<= ] [ drop simd-256 ] }
+ [ "Not a vector class" throw ]
+ } cond ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{
{ +vector+ [ drop ] }
+ { +any-vector+ [ drop parent-vector-class ] }
{ +scalar+ [ nip ] }
{ +boolean+ [ 2drop boolean ] }
{ +nonnegative+ [ nip ] }
[
{
{ +vector+ [ drop <class-info> ] }
+ { +any-vector+ [ drop parent-vector-class <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
{ +boolean+ [ 2drop boolean <class-info> ] }
{
{ hlshift { +vector+ +literal+ -> +vector+ } }
{ hrshift { +vector+ +literal+ -> +vector+ } }
{ vshuffle-elements { +vector+ +literal+ -> +vector+ } }
- { vshuffle-bytes { +vector+ +vector+ -> +vector+ } }
+ { vshuffle-bytes { +vector+ +any-vector+ -> +vector+ } }
{ vbroadcast { +vector+ +literal+ -> +vector+ } }
{ (vmerge-head) { +vector+ +vector+ -> +vector+ } }
{ (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
vxor
vnot
v?
+ vif
}
"Entire vector tests:"
{ $subsections
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
HELP: v?
-{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "result" "a sequence of numbers" } }
{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." }
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
+HELP: vif
+{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } }
+{ $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." }
+{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types."
+$nl
+"For most conditional SIMD code, unless a case is exceptionally expensive to compute, it is usually most efficient to just compute all cases and blend them with " { $link v? } " instead of using " { $snippet "vif" } "." } ;
+
+{ v? vif } related-words
+
HELP: vany?
{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
{ $description "Returns true if any element of " { $snippet "v" } " is true." }
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types assocs kernel sequences math math.functions
-hints math.order math.libm fry combinators byte-arrays accessors
-locals ;
+hints math.order math.libm math.floats.private fry combinators
+byte-arrays accessors locals ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors
: [v-] ( u v -- w ) [ [-] ] 2map ;
: v* ( u v -- w ) [ * ] 2map ;
: v/ ( u v -- w ) [ / ] 2map ;
-: vmax ( u v -- w ) [ max ] 2map ;
-: vmin ( u v -- w ) [ min ] 2map ;
+
+<PRIVATE
+
+: if-both-floats ( x y p q -- )
+ [ 2dup [ float? ] both? ] 2dip if ; inline
+
+PRIVATE>
+
+: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
+: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
: v+- ( u v -- w )
[ t ] 2dip
:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
: vshuffle-elements ( u perm -- v )
+ over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ;
: vshuffle-bytes ( u perm -- v )
underlying>> [
- swap [ '[ _ nth ] ] keep map-as
+ swap [ '[ 15 bitand _ nth ] ] keep map-as
] curry change-underlying ;
GENERIC: vshuffle ( u perm -- v )
: vunordered? ( u v -- w ) [ unordered? ] 2map ;
: v= ( u v -- w ) [ = ] 2map ;
-: v? ( mask true false -- w )
+: v? ( mask true false -- result )
[ vand ] [ vandn ] bi-curry* bi vor ; inline
+:: vif ( mask true-quot false-quot -- result )
+ {
+ { [ mask vall? ] [ true-quot call ] }
+ { [ mask vnone? ] [ false-quot call ] }
+ [ mask true-quot call false-quot call v? ]
+ } cond ; inline
+
: vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
- [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
+ [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; inline
: bilerp ( aa ba ab bb {t,u} -- a_tu )
[ first lerp ] [ second lerp ] bi-curry
- [ 2bi@ ] [ call ] bi* ;
+ [ 2bi@ ] [ call ] bi* ; inline
: vlerp ( a b t -- a_t )
- [ lerp ] 3map ;
+ [ over v- ] dip v* v+ ; inline
: vnlerp ( a b t -- a_t )
- [ lerp ] curry 2map ;
+ [ over v- ] dip v*n v+ ; inline
: vbilerp ( aa ba ab bb {t,u} -- a_tu )
[ first vnlerp ] [ second vnlerp ] bi-curry
- [ 2bi@ ] [ call ] bi* ;
+ [ 2bi@ ] [ call ] bi* ; inline
: v~ ( a b epsilon -- ? )
- [ ~ ] curry 2all? ;
+ [ ~ ] curry 2all? ; inline
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors math.vectors quotations
-accessors combinators byte-arrays specialized-arrays ;
+accessors combinators byte-arrays vocabs vocabs.loader ;
IN: mirrors
TUPLE: mirror { object read-only } ;
INSTANCE: vector enumerated-sequence
INSTANCE: callable enumerated-sequence
INSTANCE: byte-array enumerated-sequence
-INSTANCE: specialized-array enumerated-sequence
-INSTANCE: simd-128 enumerated-sequence
-INSTANCE: simd-256 enumerated-sequence
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
+
+"specialized-arrays" vocab [
+ "specialized-arrays.mirrors" require
+] when
--- /dev/null
+! Copyright (C) 2009 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup peg peg.search ;
+IN: peg.ebnf
+
+HELP: <EBNF
+{ $syntax "<EBNF ...ebnf... EBNF>" }
+{ $values { "...ebnf..." "EBNF DSL text" } }
+{ $description
+ "Creates a " { $vocab-link "peg" }
+ " object that parses a string using the syntax "
+ "defined with the EBNF DSL. The peg object can be run using the " { $link parse }
+ " word and can be used with the " { $link search } " and " { $link replace } " words."
+}
+{ $examples
+ { $example
+ "USING: kernel prettyprint peg.ebnf peg.search ;"
+ "\"abcdab\" <EBNF rule=\"a\" \"b\" => [[ drop \"foo\" ]] EBNF> replace ."
+ "\"foocdfoo\""
+ }
+} ;
+
+HELP: [EBNF
+{ $syntax "[EBNF ...ebnf... EBNF]" }
+{ $values { "...ebnf..." "EBNF DSL text" } }
+{ $description
+ "Creates and calls a quotation that parses a string using the syntax "
+ "defined with the EBNF DSL. The quotation has stack effect "
+ { $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
+ "and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
+ "quotation throws an exception."
+}
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"ab\" [EBNF rule=\"a\" \"b\" EBNF] ."
+ "V{ \"a\" \"b\" }"
+ }
+} ;
+
+HELP: EBNF:
+{ $syntax "EBNF: word ...ebnf... ;EBNF" }
+{ $values { "word" "a word" } { "...ebnf..." "EBNF DSL text" } }
+{ $description
+ "Defines a word that when called will parse a string using the syntax "
+ "defined with the EBNF DSL. The word has stack effect "
+ { $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
+ "and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
+ "word throws an exception."
+}
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "IN: scratchpad"
+ "EBNF: foo rule=\"a\" \"b\" ;EBNF"
+ "\"ab\" foo ."
+ "V{ \"a\" \"b\" }"
+ }
+} ;
+
+ARTICLE: "peg.ebnf.strings" "Strings"
+"A string in a rule will match that sequence of characters from the input string. "
+"The AST result from the match is the string itself."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"helloworld\" [EBNF rule=\"hello\" \"world\" EBNF] ."
+ "V{ \"hello\" \"world\" }"
+ }
+} ;
+
+ARTICLE: "peg.ebnf.any" "Any"
+"A full stop character (.) will match any single token in the input string. "
+"The AST resulting from this is the token itself."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"abc\" [EBNF rule=\"a\" . \"c\" EBNF] ."
+ "V{ \"a\" 98 \"c\" }"
+ }
+} ;
+
+ARTICLE: "peg.ebnf.sequence" "Sequence"
+"Any white space separated rule element is considered a sequence. Each rule "
+"in the sequence is matched from the input stream, consuming the input as it "
+"goes. The AST result is a vector containing the results of each rule element in "
+"the sequence."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"abbba\" [EBNF rule=\"a\" (\"b\")* \"a\" EBNF] ."
+ "V{ \"a\" V{ \"b\" \"b\" \"b\" } \"a\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.choice" "Choice"
+"Any rule element separated by a pipe character (|) is considered a choice. Choices "
+"are matched against the input stream in order. If a match succeeds then the remaining "
+"choices are discarded and the result of the match is the AST result of the choice."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"a\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
+ "\"a\""
+ }
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"b\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
+ "\"b\""
+ }
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"d\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
+ "Peg parsing error at character position 0.\nExpected token 'c' or token 'b' or token 'a'"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.option" "Option"
+"Any rule element followed by a question mark (?) is considered optional. The "
+"rule is tested against the input. If it succeeds the result is stored in the AST. "
+"If it fails then the parse still suceeds and false (f) is stored in the AST."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"abc\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
+ "V{ \"a\" \"b\" \"c\" }"
+ }
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"ac\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
+ "V{ \"a\" f \"c\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.character-class" "Character Class"
+"Character class matching can be done using a range of characters defined in "
+"square brackets. Multiple ranges can be included in a single character class "
+"definition. The syntax for the range is a start character, followed by a minus "
+"(-) followed by an end character. For example " { $snippet "[a-zA-Z]" } ". "
+"The AST resulting from the match is an integer of the character code for the "
+"character that matched."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"123\" [EBNF rule=[0-9]+ EBNF] ."
+ "V{ 49 50 51 }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.one-or-more" "One or more"
+"Any rule element followed by a plus (+) matches one or more instances of the rule "
+"from the input string. The AST result is the vector of the AST results from "
+"the matched rule."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"aab\" [EBNF rule=\"a\"+ \"b\" EBNF] ."
+ "V{ V{ \"a\" \"a\" } \"b\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.zero-or-more" "Zero or more"
+"Any rule element followed by an asterisk (*) matches zero or more instances of the rule "
+"from the input string. The AST result is the vector of the AST results from "
+"the matched rule. This will be empty if there are no matches."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"aab\" [EBNF rule=\"a\"* \"b\" EBNF] ."
+ "V{ V{ \"a\" \"a\" } \"b\" }"
+ }
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"b\" [EBNF rule=\"a\"* \"b\" EBNF] ."
+ "V{ V{ } \"b\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.and" "And"
+"Any rule element prefixed by an ampersand (&) performs the Parsing Expression "
+"Grammar 'And Predicate' match. It attempts to match the rule against the input "
+"string. It will cause the parse to succeed or fail depending on if the rule "
+"succeeds or fails. It will not consume anything from the input string however and "
+"does not leave any result in the AST. This can be used for lookahead and "
+"disambiguation in choices."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"ab\" [EBNF rule=&(\"a\") \"a\" \"b\" EBNF] ."
+ "V{ \"a\" \"b\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.not" "Not"
+"Any rule element prefixed by an exclamation mark (!) performs the Parsing Expression "
+"Grammar 'Not Predicate' match. It attempts to match the rule against the input "
+"string. It will cause the parse to succeed if the rule match fails, and to fail "
+"if the rule match succeeds. It will not consume anything from the input string "
+"however and does not leave any result in the AST. This can be used for lookahead and "
+"disambiguation in choices."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf ;"
+ "\"<abcd>\" [EBNF rule=\"<\" (!(\">\") .)* \">\" EBNF] ."
+ "V{ \"<\" V{ 97 98 99 100 } \">\" }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.action" "Action"
+"An action is a quotation that is run after a rule matches. The quotation "
+"consumes the AST of the rule match and leaves a new AST as the result. "
+"The stack effect of the action can be " { $snippet "( ast -- ast )" } " or "
+{ $snippet "( -- ast )" } ". "
+"If it is the latter then the original AST is implcitly dropped and will be "
+"replaced by the AST left on the stack. This is mostly useful if variables are "
+"used in the rule since they can be referenced like locals in the action quotation. "
+"The action is defined by having a ' => ' at the end of a rule and "
+"using '[[' and ']]' to open and close the quotation. "
+"If an action leaves the object 'ignore' on the stack then the result of that "
+"action will not be put in the AST of the result."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf strings ;"
+ "\"<abcd>\" [EBNF rule=\"<\" ((!(\">\") .)* => [[ >string ]]) \">\" EBNF] ."
+ "V{ \"<\" \"abcd\" \">\" }"
+ }
+ { $example
+ "USING: prettyprint peg.ebnf math.parser ;"
+ "\"123\" [EBNF rule=[0-9]+ => [[ string>number ]] EBNF] ."
+ "123"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.semantic-action" "Semantic Action"
+"Semantic actions allow providing a quotation that gets run on the AST of a "
+"matched rule that returns success or failure. The result of the parse is decided by "
+"the result of the semantic action. The stack effect for the quotation is "
+{ $snippet ( ast -- ? ) } ". "
+"A semantic action follows the rule it applies to and is delimeted by '?[' and ']?'."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf math math.parser ;"
+ "\"1\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
+ "49"
+ }
+ { $example
+ "USING: prettyprint peg.ebnf math math.parser ;"
+ "\"2\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
+ "Sequence index out of bounds\nindex 0\nseq V{ }"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.variable" "Variable"
+"Variables names can be suffixed to a rule element using the colon character (:) "
+"followed by the variable name. These can then be used in rule actions to refer to "
+"the AST result of the rule element with that variable name."
+{ $examples
+ { $example
+ "USING: prettyprint peg.ebnf math.parser ;"
+ "\"1+2\" [EBNF rule=[0-9]:a \"+\" [0-9]:b => [[ a digit> b digit> + ]] EBNF] ."
+ "3"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.foreign-rules" "Foreign Rules"
+"Rules can call outto other peg.ebnf defined parsers. The result of "
+"the foreign call then becomes the AST of the successful parse. Foreign rules "
+"are invoked using '<foreign word-name>' or '<foreign word-name rule>'. The "
+"latter allows calling a specific rule in a previously designed peg.ebnf parser. "
+"If the 'word-name' is not the name of a peg.ebnf defined parser then it must be "
+"a word with stack effect " { $snippet "( -- parser )" } ". It must return a "
+{ $vocab-link "peg" } " defined parser and it will be called to perform the parse "
+"for that rule."
+{ $examples
+ { $code
+ "USING: prettyprint peg.ebnf ;"
+ "EBNF: parse-string"
+ "StringBody = (!('\"') .)*"
+ "String= '\"' StringBody:b '\"' => [[ b >string ]]"
+ ";EBNF"
+ "EBNF: parse-two-strings"
+ "TwoStrings = <foreign parse-string String> <foreign parse-string String>"
+ ";EBNF"
+ "EBNF: parse-two-strings"
+ "TwoString = <foreign parse-string> <foreign parse-string>"
+ ";EBNF"
+ }
+ { $code
+ ": a-token ( -- parser ) \"a\" token ;"
+ "EBNF: parse-abc"
+ "abc = <foreign a-token> 'b' 'c'"
+ ";EBNF"
+ }
+}
+;
+
+ARTICLE: "peg.ebnf.tokenizers" "Tokenizers"
+"It is possible to override the tokenizer in an EBNF defined parser. "
+"Usually the input sequence to be parsed is an array of characters or a string. "
+"Terminals in a rule match successive characters in the array or string. "
+{ $examples
+ { $code
+ "EBNF: foo"
+ "rule = \"++\" \"--\""
+ ";EBNF"
+ }
+}
+"This parser when run with the string \"++--\" or the array "
+"{ CHAR: + CHAR: + CHAR: - CHAR: - } will succeed with an AST of { \"++\" \"--\" }. "
+"If you want to add whitespace handling to the grammar you need to put it "
+"between the terminals: "
+{ $examples
+ { $code
+ "EBNF: foo"
+ "space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
+ "spaces = space* => [[ drop ignore ]]"
+ "rule = spaces \"++\" spaces \"--\" spaces"
+ ";EBNF"
+ }
+}
+"In a large grammar this gets tedious and makes the grammar hard to read. "
+"Instead you can write a rule to split the input sequence into tokens, and "
+"have the grammar operate on these tokens. This is how the previous example "
+"might look: "
+{ $examples
+ { $code
+ "EBNF: foo"
+ "space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
+ "spaces = space* => [[ drop ignore ]]"
+ "tokenizer = spaces ( \"++\" | \"--\" )"
+ "rule = \"++\" \"--\""
+ ";EBNF"
+ }
+}
+"'tokenizer' is the name of a built in rule. Once defined it is called to "
+"retrieve the next complete token from the input sequence. So the first part "
+"of 'rule' is to try and match \"++\". It calls the tokenizer to get the next "
+"complete token. This ignores spaces until it finds a \"++\" or \"--\". "
+"It is as if the input sequence for the parser was actually { \"++\" \"--\" } "
+"instead of the string \"++--\". With the new tokenizer \"....\" sequences "
+"in the grammar are matched for equality against the token, rather than a "
+"string comparison against successive items in the sequence. This can be used "
+"to match an AST from a tokenizer. "
+$nl
+"In this example I split the tokenizer into a separate parser and use "
+"'foreign' to call it from the main one. This allows testing of the "
+"tokenizer separately: "
+{ $examples
+ { $example
+ "USING: prettyprint peg peg.ebnf kernel math.parser strings"
+ "accessors math arrays ;"
+ "IN: scratchpad"
+ ""
+ "TUPLE: ast-number value ;"
+ "TUPLE: ast-string value ;"
+ ""
+ "EBNF: foo-tokenizer"
+ "space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
+ "spaces = space* => [[ drop ignore ]]"
+ ""
+ "number = [0-9]+ => [[ >string string>number ast-number boa ]]"
+ "operator = (\"+\" | \"-\")"
+ ""
+ "token = spaces ( number | operator )"
+ "tokens = token*"
+ ";EBNF"
+ ""
+ "EBNF: foo"
+ "tokenizer = <foreign foo-tokenizer token>"
+ ""
+ "number = . ?[ ast-number? ]? => [[ value>> ]]"
+ "string = . ?[ ast-string? ]? => [[ value>> ]]"
+ ""
+ "rule = string:a number:b \"+\" number:c => [[ a b c + 2array ]]"
+ ";EBNF"
+ ""
+ "\"123 456 +\" foo-tokenizer ."
+ "V{\n T{ ast-number { value 123 } }\n T{ ast-number { value 456 } }\n \"+\"\n}"
+ }
+}
+"The '.' EBNF production means match a single object in the source sequence. "
+"Usually this is a character. With the replacement tokenizer it is either a "
+"number object, a string object or a string containing the operator. "
+"Using a tokenizer in language grammars makes it easier to deal with whitespace. "
+"Defining tokenizers in this way has the advantage of the tokenizer and parser "
+"working in one pass. There is no tokenization occurring over the whole string "
+"followed by the parse of that result. It tokenizes as it needs to. You can even "
+"switch tokenizers multiple times during a grammar. Rules use the tokenizer that "
+"was defined lexically before the rule. This is usefull in the JavaScript grammar: "
+{ $examples
+ { $code
+ "EBNF: javascript"
+ "tokenizer = default"
+ "nl = \"\\r\" \"\\n\" | \"\\n\""
+ "tokenizer = <foreign tokenize-javascript Tok>"
+ "..."
+ "End = !(.)"
+ "Name = . ?[ ast-name? ]? => [[ value>> ]] "
+ "Number = . ?[ ast-number? ]? => [[ value>> ]]"
+ "String = . ?[ ast-string? ]? => [[ value>> ]]"
+ "RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]"
+ "SpacesNoNl = (!(nl) Space)* => [[ ignore ]]"
+ "Sc = SpacesNoNl (nl | &(\"}\") | End)| \";\""
+ }
+}
+"Here the rule 'nl' is defined using the default tokenizer of sequential "
+"characters ('default' has the special meaning of the built in tokenizer). "
+"This is followed by using the JavaScript tokenizer for the remaining rules. "
+"This tokenizer strips out whitespace and newlines. Some rules in the grammar "
+"require checking for a newline. In particular the automatic semicolon insertion "
+"rule (managed by the 'Sc' rule here). If there is a newline, the semicolon can "
+"be optional in places. "
+{ $examples
+ { $code
+ "\"do\" Stmt:s \"while\" \"(\" Expr:c \")\" Sc => [[ s c ast-do-while boa ]]"
+ }
+}
+"Even though the JavaScript tokenizer has removed the newlines, the 'nl' rule can "
+"be used to detect them since it is using the default tokenizer. This allows "
+"grammars to mix and match the tokenizer as required to make them more readable."
+;
+
+ARTICLE: "peg.ebnf" "EBNF"
+"The " { $vocab-link "peg.ebnf" } " vocabulary provides a DSL that allows writing PEG parsers that look like "
+"EBNF syntax. It provides three parsing words described below. These words all "
+"accept the same EBNF syntax. The difference is in how they are used. "
+{ $subsection POSTPONE: <EBNF }
+{ $subsection POSTPONE: [EBNF }
+{ $subsection POSTPONE: EBNF: }
+"The EBNF syntax is composed of a series of rules of the form: "
+{ $code
+ "rule1 = ..."
+ "rule2 = ..."
+}
+"The last defined rule is the main rule for the EBNF. It is the first one run "
+"and it is expected that the remaining rules are used by that rule. Rules may be "
+"left recursive. "
+"Each rule can contain the following: "
+{ $subsection "peg.ebnf.strings" }
+{ $subsection "peg.ebnf.any" }
+{ $subsection "peg.ebnf.sequence" }
+{ $subsection "peg.ebnf.choice" }
+{ $subsection "peg.ebnf.option" }
+{ $subsection "peg.ebnf.one-or-more" }
+{ $subsection "peg.ebnf.zero-or-more" }
+{ $subsection "peg.ebnf.and" }
+{ $subsection "peg.ebnf.not" }
+{ $subsection "peg.ebnf.character-class" }
+{ $subsection "peg.ebnf.foreign-rules" }
+{ $subsection "peg.ebnf.action" }
+{ $subsection "peg.ebnf.semantic-action" }
+{ $subsection "peg.ebnf.variable" }
+"Grammars defined in EBNF need to handle each character, or sequence of "
+"characters in the input. This can be tedious for dealing with whitespace in "
+"grammars that have 'tokens' separated by whitespace. You can define your "
+"own tokenizer that for an EBNF grammar, and write the grammar in terms of "
+"those tokens, allowing you to ignore the whitespace issue. The tokenizer "
+"can be changed at various parts in the grammar as needed. The JavaScript grammar "
+"does this to define the optional semicolon rule for example."
+{ $subsection "peg.ebnf.tokenizers" }
+;
+
+ABOUT: "peg.ebnf"
\ No newline at end of file
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf words math math.parser
- sequences accessors peg.parsers parser namespaces arrays
- strings eval unicode.data multiline ;
+USING: kernel tools.test peg peg.ebnf peg.ebnf.private words
+math math.parser sequences accessors peg.parsers parser
+namespaces arrays strings eval unicode.data multiline ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
\r
ERROR: no-rule rule parser ;\r
\r
+<PRIVATE\r
+\r
: lookup-rule ( rule parser -- rule' )\r
2dup rule [ 2nip ] [ no-rule ] if* ; \r
\r
parse-ebnf dup dup parser [ main swap at compile ] with-variable\r
[ compiled-parse ] curry [ with-scope ast>> ] curry ;\r
\r
+PRIVATE>\r
+\r
SYNTAX: <EBNF\r
"EBNF>"\r
reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
{ $description "Gets the object in the heap with minumum priority." } ;
HELP: pheap-push
-{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
+{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
HELP: pheap-pop*
math.bitwise math.vectors math.vectors.simd random
sequences specialized-arrays sequences.private classes.struct
combinators.short-circuit fry ;
-SIMD: uint
+SIMDS: uchar uint ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: uint-4
IN: random.sfmt
{ uint-array uint-array }
{ uint-4-array uint-4-array } ;
+: endian-shuffle ( v -- w )
+ little-endian? [
+ uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } vshuffle
+ ] unless ; inline
+
+: hlshift* ( v n -- w )
+ [ endian-shuffle ] dip hlshift endian-shuffle ; inline
+
+: hrshift* ( v n -- w )
+ [ endian-shuffle ] dip hrshift endian-shuffle ; inline
+
: wA ( w -- wA )
- dup 1 hlshift vbitxor ; inline
+ dup 1 hlshift* vbitxor ; inline
: wB ( w mask -- wB )
[ 11 vrshift ] dip vbitand ; inline
: wC ( w -- wC )
- 1 hrshift ; inline
+ 1 hrshift* ; inline
: wD ( w -- wD )
18 vlshift ; inline
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: sequences.generalizations
+
+HELP: neach
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
+{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
+
+HELP: nmap
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
+
+HELP: nmap-as
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
+
+HELP: mnmap
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
+
+HELP: mnmap-as
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
+
+HELP: nproduce
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
+{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+HELP: nproduce-as
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
+"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
+{ $subsections
+ neach
+ nmap
+ nmap-as
+ mnmap
+ mnmap-as
+ nproduce
+ nproduce-as
+} ;
+
+ABOUT: "sequences.generalizations"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: tools.test generalizations kernel math arrays sequences
+sequences.generalizations ascii fry math.parser io io.streams.string ;
+IN: sequences.generalizations.tests
+
+: neach-test ( a b c d -- )
+ [ 4 nappend print ] 4 neach ;
+: nmap-test ( a b c d -- e )
+ [ 4 nappend ] 4 nmap ;
+: nmap-as-test ( a b c d -- e )
+ [ 4 nappend ] [ ] 4 nmap-as ;
+: mnmap-3-test ( a b c d -- e f g )
+ [ append ] 4 3 mnmap ;
+: mnmap-2-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] 4 2 mnmap ;
+: mnmap-as-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
+: mnmap-1-test ( a b c d -- e )
+ [ 4 nappend ] 4 1 mnmap ;
+: mnmap-0-test ( a b c d -- )
+ [ 4 nappend print ] 4 0 mnmap ;
+: nproduce-as-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as
+ [ drop ] 2dip ;
+: nproduce-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce
+ [ drop ] 2dip ;
+
+[ """A1a!
+B2b@
+C3c#
+D4d$
+""" ] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ neach-test ] with-string-writer
+] unit-test
+
+[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-test
+] unit-test
+
+[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-as-test
+] unit-test
+
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a!" "b@" "c#" "d$" }
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-3-test
+] unit-test
+
+[
+ { "A1" "B2" "C3" "D4" }
+ { "a!" "b@" "c#" "d$" }
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-2-test
+] unit-test
+
+[
+ { "A1" "B2" "C3" "D4" }
+ [ "a!" "b@" "c#" "d$" ]
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-as-test
+] unit-test
+
+[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-1-test
+] unit-test
+
+[ """A1a!
+B2b@
+C3c#
+D4d$
+""" ] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ mnmap-0-test ] with-string-writer
+] unit-test
+
+[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ]
+[ 10 nproduce-as-test ] unit-test
+
+[ { 10 8 6 4 2 } { 9 7 5 3 1 } ]
+[ 10 nproduce-test ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel sequences sequences.private math
+combinators macros math.order math.ranges quotations fry effects
+memoize.private generalizations ;
+IN: sequences.generalizations
+
+MACRO: nmin-length ( n -- )
+ dup 1 - [ min ] n*quot
+ '[ [ length ] _ napply @ ] ;
+
+: nnth-unsafe ( n ...seq n -- )
+ [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
+MACRO: nset-nth-unsafe ( n -- )
+ [ [ drop ] ]
+ [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
+ if-zero ;
+
+: (neach) ( ...seq quot n -- len quot' )
+ dup dup dup
+ '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
+
+: neach ( ...seq quot n -- )
+ (neach) each-integer ; inline
+
+: nmap-as ( ...seq quot exemplar n -- result )
+ '[ _ (neach) ] dip map-integers ; inline
+
+: nmap ( ...seq quot n -- result )
+ dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
+
+MACRO: nnew-sequence ( n -- )
+ [ [ drop ] ]
+ [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
+
+: nnew-like ( len ...exemplar quot n -- result... )
+ 5 dupn '[
+ _ nover
+ [ [ _ nnew-sequence ] dip call ]
+ _ ndip [ like ]
+ _ apply-curry
+ _ spread*
+ ] call ; inline
+
+MACRO: (ncollect) ( n -- )
+ 3 dupn 1 +
+ '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
+
+: ncollect ( len quot ...into n -- )
+ (ncollect) each-integer ; inline
+
+: nmap-integers ( len quot ...exemplar n -- result... )
+ 4 dupn
+ '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
+
+: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
+ dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
+
+: mnmap ( m*seq quot m n -- result*n )
+ 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
+
+: naccumulator-for ( quot ...exemplar n -- quot' vec... )
+ 5 dupn '[
+ [ [ length ] keep new-resizable ] _ napply
+ [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
+ ] call ; inline
+
+: naccumulator ( quot n -- quot' vec... )
+ [ V{ } swap dupn ] keep naccumulator-for ; inline
+
+: nproduce-as ( pred quot ...exemplar n -- seq... )
+ 7 dupn '[
+ _ ndup
+ [ _ naccumulator-for [ while ] _ ndip ]
+ _ ncurry _ ndip
+ [ like ] _ apply-curry _ spread*
+ ] call ; inline
+
+: nproduce ( pred quot n -- seq... )
+ [ { } swap dupn ] keep nproduce-as ; inline
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: mirrors specialized-arrays math.vectors ;
+IN: specialized-arrays.mirrors
+
+INSTANCE: specialized-array enumerated-sequence
+INSTANCE: simd-128 enumerated-sequence
+INSTANCE: simd-256 enumerated-sequence
ARTICLE: "specialized-arrays" "Specialized arrays"
"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
$nl
-"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
+"A specialized array type needs to be generated for each element type. This is done with parsing words:"
{ $subsections
POSTPONE: SPECIALIZED-ARRAY:
POSTPONE: SPECIALIZED-ARRAYS:
kernel arrays combinators compiler compiler.units classes.struct
combinators.smart compiler.tree.debugger math libc destructors
sequences.private multiline eval words vocabs namespaces
-assocs prettyprint alien.data math.vectors ;
+assocs prettyprint alien.data math.vectors definitions ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
! If the C type doesn't exist, don't generate a vocab
-[ ] [
- [ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
- "__does_not_exist__" c-types get delete-at
-] unit-test
+SYMBOL: __does_not_exist__
[
"""
[ f ] [
"__does_not_exist__-array{"
- "__does_not_exist__" specialized-array-vocab lookup
+ __does_not_exist__ specialized-array-vocab lookup
deferred?
] unit-test
+
+[ ] [
+ [
+ \ __does_not_exist__ forget
+ __does_not_exist__ specialized-array-vocab forget-vocab
+ ] with-compilation-unit
+] unit-test
math.vectors.specialization namespaces
parser prettyprint.custom sequences sequences.private strings
summary vocabs vocabs.loader vocabs.parser vocabs.generated
-words fry combinators present ;
+words fry combinators make ;
IN: specialized-arrays
MIXIN: specialized-array
[ drop ]
} cond ;
-: underlying-type-name ( c-type -- name )
- underlying-type present ;
-
: specialized-array-vocab ( c-type -- vocab )
- present "specialized-arrays.instances." prepend ;
+ [
+ "specialized-arrays.instances." %
+ [ vocabulary>> % "." % ]
+ [ name>> % ]
+ bi
+ ] "" make ;
PRIVATE>
ERROR: specialized-array-vocab-not-loaded c-type ;
M: c-type-name c-array-constructor
- underlying-type-name
- dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ underlying-type
+ dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: c-type-name c-(array)-constructor
- underlying-type-name
- dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
+ underlying-type
+ dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: c-type-name c-direct-array-constructor
- underlying-type-name
- dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ underlying-type
+ dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
SYNTAX: SPECIALIZED-ARRAYS:
"prettyprint" vocab [
"specialized-arrays.prettyprint" require
] when
+
+"mirrors" vocab [
+ "specialized-arrays.mirrors" require
+] when
{ $values { "type" "a C type" } }
{ $description "Brings a specialized vector for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
+HELP: SPECIALIZED-VECTORS:
+{ $syntax "SPECIALIZED-VECTORS: type type type ... ;" }
+{ $values { "type" "a C type" } }
+{ $description "Brings a set of specialized vectors for holding values of each " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
+
+{ POSTPONE: SPECIALIZED-VECTOR: POSTPONE: SPECIALIZED-VECTORS: } related-words
+
ARTICLE: "specialized-vector-words" "Specialized vector words"
"The " { $link POSTPONE: SPECIALIZED-VECTOR: } " parsing word generates the specialized vector type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
ARTICLE: "specialized-vectors" "Specialized vectors"
"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
+$nl
+"A specialized vector type needs to be generated for each element type. This is done with parsing words:"
+{ $subsections
+ POSTPONE: SPECIALIZED-VECTOR:
+ POSTPONE: SPECIALIZED-VECTORS:
+}
{ $subsections
"specialized-vector-words"
"specialized-vector-c"
USING: specialized-arrays specialized-vectors
tools.test kernel sequences alien.c-types ;
SPECIALIZED-ARRAY: float
-SPECIALIZED-VECTOR: float
-SPECIALIZED-VECTOR: double
+SPECIALIZED-VECTORS: float double ;
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs compiler.units functors
-growable kernel lexer namespaces parser prettyprint.custom
-sequences specialized-arrays specialized-arrays.private strings
-vocabs vocabs.parser vocabs.generated fry ;
+USING: accessors alien.c-types alien.parser assocs
+compiler.units functors growable kernel lexer namespaces parser
+prettyprint.custom sequences specialized-arrays
+specialized-arrays.private strings vocabs vocabs.parser
+vocabs.generated fry make ;
QUALIFIED: vectors.functor
IN: specialized-vectors
;FUNCTOR
-: specialized-vector-vocab ( type -- vocab )
- "specialized-vectors.instances." prepend ;
+: specialized-vector-vocab ( c-type -- vocab )
+ [
+ "specialized-vectors.instances." %
+ [ vocabulary>> % "." % ]
+ [ name>> % ]
+ bi
+ ] "" make ;
PRIVATE>
[ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
generate-vocab ;
+SYNTAX: SPECIALIZED-VECTORS:
+ ";" parse-tokens [
+ parse-c-type
+ [ define-array-vocab use-vocab ]
+ [ define-vector-vocab use-vocab ] bi
+ ] each ;
+
SYNTAX: SPECIALIZED-VECTOR:
- scan
+ scan-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi ;
\ (save-image-and-exit) { byte-array } { } define-primitive
-\ data-room { } { integer integer array } define-primitive
+\ data-room { } { array } define-primitive
\ data-room make-flushable
-\ code-room { } { integer integer integer integer } define-primitive
+\ code-room { } { array } define-primitive
\ code-room make-flushable
\ micros { } { integer } define-primitive
{ $heading "Limitations" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
- "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
+ "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected"
}
"To make this work, pass the quotation on the retain stack instead:"
{ $example
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
{ $heading "Input quotation declaration" }
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
-{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
+{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected" }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
"The stack checker does not trace data flow in two instances."
$nl
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
-{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
+{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected" }
"However a small change can be made:"
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
IN: system-info.linux
: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
+ int f "uname" { char* } alien-invoke ;
: uname ( -- seq )
65536 <char-array> [ (uname) io-error ] keep
\r
[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
-[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test\r
+[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
\r
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
rest\r
] unit-test\r
\r
-[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
\ No newline at end of file
+[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct cocoa cocoa.classes
-cocoa.subclassing core-graphics.types kernel math ;
+cocoa.runtime cocoa.subclassing cocoa.types core-graphics.types
+kernel math ;
+FROM: alien.c-types => float ;
IN: tools.deploy.test.14
CLASS: {
{ +name+ "Bar" }
} {
"bar:"
- "float"
- { "id" "SEL" "NSRect" }
+ float
+ { id SEL NSRect }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]
-USING: alien kernel math ;
+USING: alien alien.c-types kernel math ;
IN: tools.deploy.test.9
: callback-test ( -- callback )
- "int" { "int" } "cdecl" [ 1 + ] alien-callback ;
+ int { int } "cdecl" [ 1 + ] alien-callback ;
: indirect-test ( -- )
- 10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
+ 10 callback-test int { int } "cdecl" alien-indirect 11 assert= ;
MAIN: indirect-test
[
cell 4 / *
cpu ppc? [ 100000 + ] when
- os windows? [ 250000 + ] when
+ os windows? [ 150000 + ] when
] bi*
<= ;
"-i=" "test.image" temp-file append 2array ;
: run-temp-image ( -- )
- deploy-test-command try-output-process ;
\ No newline at end of file
+ deploy-test-command try-output-process ;
#! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting
-M: source-file-error compute-restarts error>> compute-restarts ;
-
-M: source-file-error error-help error>> error-help ;
-
CONSTANT: +listener-input+ "<Listener input>"
: error-location ( error -- string )
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays generic assocs io math
namespaces parser prettyprint strings io.styles words
<PRIVATE
-: write-size ( n -- )
+: kilobytes ( n -- str )
number>string
dup length 4 > [ 3 cut* "," glue ] when
- " KB" append write-cell ;
-
-: write-total/used/free ( free total str -- )
- [
- write-cell
- dup write-size
- over - write-size
- write-size
- ] with-row ;
-
-: write-total ( n str -- )
- [
- write-cell
- write-size
- [ ] with-cell
- [ ] with-cell
- ] with-row ;
-
-: write-headings ( seq -- )
- [ [ write-cell ] each ] with-row ;
-
-: (data-room.) ( -- )
- data-room 2 <groups> [
- [ first2 ] [ number>string "Generation " prepend ] bi*
- write-total/used/free
- ] each-index
- "Decks" write-total
- "Cards" write-total ;
-
-: write-labeled-size ( n string -- )
- [ write-cell write-size ] with-row ;
-
-: (code-room.) ( -- )
- code-room {
- [ "Size:" write-labeled-size ]
- [ "Used:" write-labeled-size ]
- [ "Total free space:" write-labeled-size ]
- [ "Largest free block:" write-labeled-size ]
- } spread ;
+ " KB" append ;
+
+: memory-table. ( sizes seq -- )
+ swap [ kilobytes ] map zip simple-table. ;
+
+: young-room. ( seq -- )
+ { "Total:" "Allocated:" "Free:" } memory-table. ;
+
+: nursery-room. ( seq -- ) "- Nursery space" print young-room. ;
+
+: aging-room. ( seq -- ) "- Aging space" print young-room. ;
+
+: mark-sweep-table. ( sizes -- )
+ { "Total:" "Allocated:" "Contiguous free:" "Total free:" } memory-table. ;
+
+: tenured-room. ( seq -- ) "- Tenured space" print mark-sweep-table. ;
+
+: misc-room. ( seq -- )
+ "- Miscellaneous buffers" print
+ { "Card array:" "Deck array:" "Mark stack:" } memory-table. ;
+
+: data-room. ( -- )
+ "==== DATA HEAP" print nl
+ data-room
+ 3 cut [ nursery-room. nl ] dip
+ 3 cut [ aging-room. nl ] dip
+ 4 cut [ tenured-room. nl ] dip
+ misc-room. ;
+
+: code-room. ( -- )
+ "==== CODE HEAP" print nl
+ code-room mark-sweep-table. ;
: heap-stat-step ( obj counts sizes -- )
[ [ class ] dip inc-at ]
PRIVATE>
-: room. ( -- )
- "==== DATA HEAP" print
- standard-table-style [
- { "" "Total" "Used" "Free" } write-headings
- (data-room.)
- ] tabular-output
- nl nl
- "==== CODE HEAP" print
- standard-table-style [
- (code-room.)
- ] tabular-output
- nl ;
+: room. ( -- ) data-room. nl code-room. ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
: heap-stats. ( -- )
heap-stats dup keys natural-sort standard-table-style [
- { "Class" "Bytes" "Instances" } write-headings
+ [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
[
[
dup pprint-cell
-IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences compiler compiler.units
-words ;
+threads alien alien.c-types tools.profiler.private sequences
+compiler compiler.units words ;
+IN: tools.profiler.tests
[ t ] [
\ length counter>>
[ ] [ \ + usage-profile. ] unit-test
-: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+: callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ;
-: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
+: indirect-test ( callback -- ) void { } "cdecl" alien-indirect ;
: foobar ( -- ) ;
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
HELP: breakpoint-if
-{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
+{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: B
! (c)Joe Groff bsd license
-USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
+USING: typed compiler.cfg.debugger compiler.tree.debugger
+tools.disassembler words ;
IN: typed.debugger
: typed-test-mr ( word -- mrs )
"typed-word" word-prop test-mr mr. ; inline
: typed-optimized. ( word -- )
"typed-word" word-prop optimized. ; inline
+
+: typed-disassemble ( word -- )
+ "typed-word" word-prop disassemble ; inline
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
-cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation core-foundation.strings help.topics kernel
-memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.backend.cocoa eval locals
-vocabs.refresh ;
+cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
+cocoa.subclassing core-foundation core-foundation.strings
+help.topics kernel memory namespaces parser system ui
+ui.tools.browser ui.tools.listener ui.backend.cocoa eval
+locals vocabs.refresh ;
+FROM: alien.c-types => int void ;
IN: ui.backend.cocoa.tools
: finder-run-files ( alien -- )
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+{ "application:openFiles:" void { id SEL id id }
[ [ 3drop ] dip finder-run-files ]
}
-{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
+{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
-{ "factorListener:" "id" { "id" "SEL" "id" }
+{ "factorListener:" id { id SEL id }
[ 3drop show-listener f ]
}
-{ "factorBrowser:" "id" { "id" "SEL" "id" }
+{ "factorBrowser:" id { id SEL id }
[ 3drop show-browser f ]
}
-{ "newFactorListener:" "id" { "id" "SEL" "id" }
+{ "newFactorListener:" id { id SEL id }
[ 3drop listener-window f ]
}
-{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
+{ "newFactorBrowser:" id { id SEL id }
[ 3drop browser-window f ]
}
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
+{ "runFactorFile:" id { id SEL id }
[ 3drop menu-run-files f ]
}
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+{ "saveFactorImage:" id { id SEL id }
[ 3drop save f ]
}
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+{ "saveFactorImageAs:" id { id SEL id }
[ 3drop menu-save-image f ]
}
-{ "refreshAll:" "id" { "id" "SEL" "id" }
+{ "refreshAll:" id { id SEL id }
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
{ +name+ "FactorServiceProvider" }
} {
"evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval-listener f ] do-service 2drop ]
} {
"evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval>string ] do-service 2drop ]
} ;
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private
-ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
+ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
IN: ui.backend.cocoa.views
}
! Rendering
-{ "drawRect:" "void" { "id" "SEL" "NSRect" }
+{ "drawRect:" void { id SEL NSRect }
[ 2drop window relayout-1 yield ]
}
! Events
-{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
+{ "acceptsFirstMouse:" char { id SEL id }
[ 3drop 1 ]
}
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
+{ "mouseEntered:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseExited:" "void" { "id" "SEL" "id" }
+{ "mouseExited:" void { id SEL id }
[ 3drop forget-rollover ]
}
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
+{ "mouseMoved:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
+{ "mouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+{ "rightMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+{ "otherMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseDown:" "void" { "id" "SEL" "id" }
+{ "mouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "mouseUp:" "void" { "id" "SEL" "id" }
+{ "mouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+{ "rightMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+{ "rightMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+{ "otherMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+{ "otherMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
+{ "scrollWheel:" void { id SEL id }
[ nip send-wheel$ ]
}
-{ "keyDown:" "void" { "id" "SEL" "id" }
+{ "keyDown:" void { id SEL id }
[ nip send-key-down-event ]
}
-{ "keyUp:" "void" { "id" "SEL" "id" }
+{ "keyUp:" void { id SEL id }
[ nip send-key-up-event ]
}
-{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
+{ "validateUserInterfaceItem:" char { id SEL id }
[
nip -> action
2dup [ window ] [ utf8 alien>string ] bi* validate-action
]
}
-{ "undo:" "id" { "id" "SEL" "id" }
+{ "undo:" id { id SEL id }
[ nip undo-action send-action$ ]
}
-{ "redo:" "id" { "id" "SEL" "id" }
+{ "redo:" id { id SEL id }
[ nip redo-action send-action$ ]
}
-{ "cut:" "id" { "id" "SEL" "id" }
+{ "cut:" id { id SEL id }
[ nip cut-action send-action$ ]
}
-{ "copy:" "id" { "id" "SEL" "id" }
+{ "copy:" id { id SEL id }
[ nip copy-action send-action$ ]
}
-{ "paste:" "id" { "id" "SEL" "id" }
+{ "paste:" id { id SEL id }
[ nip paste-action send-action$ ]
}
-{ "delete:" "id" { "id" "SEL" "id" }
+{ "delete:" id { id SEL id }
[ nip delete-action send-action$ ]
}
-{ "selectAll:" "id" { "id" "SEL" "id" }
+{ "selectAll:" id { id SEL id }
[ nip select-all-action send-action$ ]
}
-{ "newDocument:" "id" { "id" "SEL" "id" }
+{ "newDocument:" id { id SEL id }
[ nip new-action send-action$ ]
}
-{ "openDocument:" "id" { "id" "SEL" "id" }
+{ "openDocument:" id { id SEL id }
[ nip open-action send-action$ ]
}
-{ "saveDocument:" "id" { "id" "SEL" "id" }
+{ "saveDocument:" id { id SEL id }
[ nip save-action send-action$ ]
}
-{ "saveDocumentAs:" "id" { "id" "SEL" "id" }
+{ "saveDocumentAs:" id { id SEL id }
[ nip save-as-action send-action$ ]
}
-{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" }
+{ "revertDocumentToSaved:" id { id SEL id }
[ nip revert-action send-action$ ]
}
! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+{ "magnifyWithEvent:" void { id SEL id }
[
nip
dup -> deltaZ sgn {
]
}
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+{ "swipeWithEvent:" void { id SEL id }
[
nip
dup -> deltaX sgn {
]
}
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+! "rotateWithEvent:" void { id SEL id }}
-{ "acceptsFirstResponder" "char" { "id" "SEL" }
+{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+{ "validRequestorForSendType:returnType:" id { id SEL id id }
[
! We return either self or nil
[ over window-focus ] 2dip
]
}
-{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
+{ "writeSelectionToPasteboard:types:" char { id SEL id id }
[
CF>string-array NSStringPboardType swap member? [
[ drop window-focus gadget-selection ] dip over
]
}
-{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
+{ "readSelectionFromPasteboard:" char { id SEL id }
[
pasteboard-string dup [
[ drop window ] dip swap user-input 1
}
! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
+{ "insertText:" void { id SEL id }
[ nip CF>string swap window user-input ]
}
-{ "hasMarkedText" "char" { "id" "SEL" }
+{ "hasMarkedText" char { id SEL }
[ 2drop 0 ]
}
-{ "markedRange" "NSRange" { "id" "SEL" }
+{ "markedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
-{ "selectedRange" "NSRange" { "id" "SEL" }
+{ "selectedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
[ 2drop 2drop ]
}
-{ "unmarkText" "void" { "id" "SEL" }
+{ "unmarkText" void { id SEL }
[ 2drop ]
}
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+{ "validAttributesForMarkedText" id { id SEL }
[ 2drop NSArray -> array ]
}
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+{ "attributedSubstringFromRange:" id { id SEL NSRange }
[ 3drop f ]
}
-{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
+{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
[ 3drop 0 ]
}
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
[ 3drop 0 0 0 0 <CGRect> ]
}
-{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
+{ "conversationIdentifier" NSInteger { id SEL }
[ drop alien-address ]
}
! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+{ "updateFactorGadgetSize:" void { id SEL id }
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
-{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+{ "doCommandBySelector:" void { id SEL SEL }
[ 3drop ]
}
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
[
[ drop ] 2dip
SUPER-> initWithFrame:pixelFormat:
]
}
-{ "isOpaque" "char" { "id" "SEL" }
+{ "isOpaque" char { id SEL }
[
2drop 0
]
}
-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
[
drop
[ unregister-window ]
{ +name+ "FactorWindowDelegate" }
}
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
+{ "windowDidMove:" void { id SEL id }
[
2nip -> object [ -> contentView window ] keep save-position
]
}
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+{ "windowDidBecomeKey:" void { id SEL id }
[
2nip -> object -> contentView window focus-world
]
}
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+{ "windowDidResignKey:" void { id SEL id }
[
forget-rollover
2nip -> object -> contentView
]
}
-{ "windowShouldClose:" "char" { "id" "SEL" "id" }
+{ "windowShouldClose:" char { id SEL id }
[
3drop 1
]
}
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
+{ "windowWillClose:" void { id SEL id }
[
2nip -> object -> contentView window ungraft
]
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ uint { void* uint long long } "stdcall" [
pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
-USING: accessors ui.gadgets.editors tools.test kernel io
-io.streams.plain definitions namespaces ui.gadgets
-ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.debug
-models documents.elements ui.gadgets.scrollers ui.gadgets.line-support
-sequences ;
+USING: accessors ui.gadgets.editors ui.gadgets.editors.private
+tools.test kernel io io.streams.plain definitions namespaces
+ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures
+ui.gadgets.debug models documents.elements ui.gadgets.scrollers
+ui.gadgets.line-support sequences ;
IN: ui.gadgets.editors.tests
[ "foo bar" ] [
[ ] [ <editor> com-join-lines ] unit-test
[ ] [ <editor> "A" over set-editor-string com-join-lines ] unit-test
[ "A B" ] [ <editor> "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A B\nC\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 0 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A\nB C\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 1 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A\nB\nC D" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 2 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
[ 2 ] [ <editor> 20 >>min-rows 20 >>min-cols pref-viewport-dim length ] unit-test
caret mark
focused? blink blink-alarm ;
+<PRIVATE
+
: <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- editor )
COLOR: red >>caret-color
monospace-font >>font ; inline
+PRIVATE>
+
: new-editor ( class -- editor )
new-line-gadget
<document> >>model
: <editor> ( -- editor )
editor new-editor ;
+<PRIVATE
+
: activate-editor-model ( editor model -- )
[ add-connection ]
[ nip activate-model ]
bi
] [ drop ] if ;
+PRIVATE>
+
M: editor graft*
[ dup caret>> activate-editor-model ]
[ dup mark>> activate-editor-model ] bi ;
] keep scroll>rect
] [ drop ] if ;
+<PRIVATE
+
: draw-caret? ( editor -- ? )
{ [ focused?>> ] [ blink>> ] } 1&& ;
] 3bi
] if ;
+PRIVATE>
+
M: editor draw-line ( line index editor -- )
[ selected-lines get at ] dip over
[ draw-selected-line ] [ nip draw-unselected-line ] if ;
M: editor cap-height font>> font-metrics cap-height>> ;
+<PRIVATE
+
: contents-changed ( model editor -- )
[ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
[ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
: caret/mark-changed ( editor -- )
[ restart-blinking ] keep scroll>caret ;
+PRIVATE>
+
M: editor model-changed
{
{ [ 2dup model>> eq? ] [ contents-changed ] }
: change-selection ( editor quot -- )
'[ gadget-selection @ ] [ user-input* drop ] bi ; inline
+<PRIVATE
+
: join-lines ( string -- string' )
"\n" split
[ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
[ " " join ]
tri ;
+: last-line? ( document line -- ? )
+ [ last-line# ] dip = ;
+
+: prev-line-and-this ( document line -- start end )
+ swap
+ [ drop 1 - 0 2array ]
+ [ [ drop ] [ doc-line length ] 2bi 2array ]
+ 2bi ;
+
+: join-with-prev ( document line -- )
+ [ prev-line-and-this ] [ drop ] 2bi
+ [ join-lines ] change-doc-range ;
+
: this-line-and-next ( document line -- start end )
- [ nip 0 swap 2array ]
- [ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ]
+ swap
+ [ drop 0 2array ]
+ [ [ 1 + ] dip [ drop ] [ doc-line length ] 2bi 2array ]
2bi ;
-: last-line? ( document line -- ? )
- [ last-line# ] dip = ;
+: join-with-next ( document line -- )
+ [ this-line-and-next ] [ drop ] 2bi
+ [ join-lines ] change-doc-range ;
+
+PRIVATE>
: com-join-lines ( editor -- )
dup gadget-selection?
[ [ join-lines ] change-selection ] [
- [ model>> ] [ editor-caret first ] bi
- 2dup last-line? [ 2drop ] [
- [ this-line-and-next ] [ drop ] 2bi
- [ join-lines ] change-doc-range
- ] if
+ [ model>> ] [ editor-caret first ] bi {
+ { [ over last-line# 0 = ] [ 2drop ] }
+ { [ 2dup last-line? ] [ join-with-prev ] }
+ [ join-with-next ]
+ } cond
] if ;
multiline-editor "multiline" f {
! Fields wrap an editor
TUPLE: field < border editor min-cols max-cols ;
+<PRIVATE
+
: field-theme ( gadget -- gadget )
{ 2 2 } >>size
{ 1 0 } >>fill
{ 1 0 } >>fill
field-theme ;
+PRIVATE>
+
: new-field ( class -- gadget )
[ <editor> ] dip new-border
dup gadget-child >>editor
IN: ui.gadgets.menus
HELP: <commands-menu>
-{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } } { "menu" "a new " { $link gadget } } }
+{ $values { "target" object } { "hook" { $quotation "( button -- )" } } { "commands" "a sequence of commands" } { "menu" "a new " { $link gadget } } }
{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
HELP: show-menu
{ <viewport> <scroller> } related-words
HELP: set-scroll-position
-{ $values { "scroller" scroller } { "value" "a pair of integers" } }
+{ $values { "value" "a pair of integers" } { "scroller" scroller } }
{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
HELP: relative-scroll-rect
{ $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ;
HELP: track-add
-{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
+{ $values { "track" track } { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
ABOUT: "ui-track-layout"
USING: help.markup help.syntax kernel ui.gadgets ;
HELP: draw-interior
-{ $values { "pen" object } { "gadget" gadget } }
+{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
HELP: draw-boundary
-{ $values { "pen" object } { "gadget" gadget } }
+{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
ARTICLE: "ui-pen-protocol" "UI pen protocol"
{ $vocab-subsection "Polygon pens" "ui.pens.polygon" }
{ $vocab-subsection "Solid pens" "ui.pens.solid" }
{ $vocab-subsection "Tile pens" "ui.pens.tile" }
-"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
\ No newline at end of file
+"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
M: A new-resizable drop <V> ; inline
+M: V new-resizable drop <V> ; inline
+
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
CONSTANT: PIPE_UNLIMITED_INSTANCES 255
+CONSTANT: EXCEPTION_NONCONTINUABLE HEX: 1
+CONSTANT: STATUS_GUARD_PAGE_VIOLATION HEX: 80000001
+CONSTANT: STATUS_DATATYPE_MISALIGNMENT HEX: 80000002
+CONSTANT: STATUS_BREAKPOINT HEX: 80000003
+CONSTANT: STATUS_SINGLE_STEP HEX: 80000004
+CONSTANT: STATUS_ACCESS_VIOLATION HEX: C0000005
+CONSTANT: STATUS_IN_PAGE_ERROR HEX: C0000006
+CONSTANT: STATUS_INVALID_HANDLE HEX: C0000008
+CONSTANT: STATUS_NO_MEMORY HEX: C0000017
+CONSTANT: STATUS_ILLEGAL_INSTRUCTION HEX: C000001D
+CONSTANT: STATUS_NONCONTINUABLE_EXCEPTION HEX: C0000025
+CONSTANT: STATUS_INVALID_DISPOSITION HEX: C0000026
+CONSTANT: STATUS_ARRAY_BOUNDS_EXCEEDED HEX: C000008C
+CONSTANT: STATUS_FLOAT_DENORMAL_OPERAND HEX: C000008D
+CONSTANT: STATUS_FLOAT_DIVIDE_BY_ZERO HEX: C000008E
+CONSTANT: STATUS_FLOAT_INEXACT_RESULT HEX: C000008F
+CONSTANT: STATUS_FLOAT_INVALID_OPERATION HEX: C0000090
+CONSTANT: STATUS_FLOAT_OVERFLOW HEX: C0000091
+CONSTANT: STATUS_FLOAT_STACK_CHECK HEX: C0000092
+CONSTANT: STATUS_FLOAT_UNDERFLOW HEX: C0000093
+CONSTANT: STATUS_INTEGER_DIVIDE_BY_ZERO HEX: C0000094
+CONSTANT: STATUS_INTEGER_OVERFLOW HEX: C0000095
+CONSTANT: STATUS_PRIVILEGED_INSTRUCTION HEX: C0000096
+CONSTANT: STATUS_STACK_OVERFLOW HEX: C00000FD
+CONSTANT: STATUS_CONTROL_C_EXIT HEX: C000013A
+CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS HEX: C00002B4
+CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS HEX: C00002B5
+
LIBRARY: kernel32
! FUNCTION: _hread
! FUNCTION: _hwrite
HELP: alien-callback
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
{ $description
- "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
+ "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl
"When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
$nl
"A simple example, showing a C function which returns the difference of two given integers:"
{ $code
": difference-callback ( -- alien )"
- " \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;"
+ " int { int int } \"cdecl\" [ - ] alien-callback ;"
}
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
quotations assocs layouts classes.tuple.private
kernel.private ;
+16 data-alignment set
+
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
\r
M: byte-array new-resizable drop <byte-vector> ; inline\r
\r
+M: byte-vector new-resizable drop <byte-vector> ; inline\r
+\r
INSTANCE: byte-vector growable\r
builtin-class
builtin-class?
}
-"See " { $link "type-index" } " for a list of built-in classes." ;
+"See " { $link "class-index" } " for a list of built-in classes." ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: case>quot
-{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
+{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"This word uses three strategies:"
{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
HELP: >continuation<
-{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } }
+{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc
HELP: restart
{ $values { "restart" restart } }
{ $description "Invokes a restart." }
-{ $class-description "The class of restarts." } ;
\ No newline at end of file
+{ $class-description "The class of restarts." } ;
$low-level-note ;
HELP: define-generic
-{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
+{ $values { "word" word } { "combination" "a method combination" } { "effect" effect } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
-SPECIALIZED-VECTOR: double
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-VECTOR: c:double
IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
2dup (>>length)
] when 2drop ; inline
+M: growable new-resizable new-sequence 0 over set-length ; inline
+
INSTANCE: growable sequence
: bl ( -- ) " " write ;
-<PRIVATE
-
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
-: stream-element-exemplar ( type -- exemplar )
+<PRIVATE
+
+: (stream-element-exemplar) ( type -- exemplar )
{
{ +byte+ [ B{ } ] }
{ +character+ [ "" ] }
- } case ;
+ } case ; inline
+
+: stream-element-exemplar ( stream -- exemplar )
+ stream-element-type (stream-element-exemplar) ;
: element-exemplar ( -- exemplar )
- input-stream get
- stream-element-type
- stream-element-exemplar ;
+ input-stream get stream-element-exemplar ; inline
PRIVATE>
+: each-stream-line ( stream quot -- )
+ swap [ stream-readln ] curry each-morsel ; inline
+
: each-line ( quot -- )
- [ readln ] each-morsel ; inline
+ input-stream get swap each-stream-line ; inline
+
+: stream-lines ( stream -- seq )
+ [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ;
: lines ( -- seq )
- [ ] accumulator [ each-line ] dip { } like ;
+ input-stream get stream-lines ; inline
-: stream-lines ( stream -- seq )
- [ lines ] with-input-stream ;
+: stream-contents ( stream -- seq )
+ [
+ [ [ 65536 swap stream-read-partial dup ] curry [ ] produce nip ]
+ [ stream-element-exemplar concat-as ] bi
+ ] with-disposal ;
: contents ( -- seq )
- [ 65536 read-partial dup ] [ ] produce nip
- element-exemplar concat-as ;
+ input-stream get stream-contents ; inline
-: stream-contents ( stream -- seq )
- [ contents ] with-input-stream ;
+: each-stream-block ( stream quot: ( block -- ) -- )
+ swap [ 8192 swap stream-read-partial ] curry each-morsel ; inline
: each-block ( quot: ( block -- ) -- )
- [ 8192 read-partial ] each-morsel ; inline
+ input-stream get swap each-stream-block ; inline
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]
{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
HELP: with-byte-reader
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation } { "byte-array" byte-array } }
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
HELP: with-byte-writer
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
-{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
} ;
HELP: either?
-{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: keep
-{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
+{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
-{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
HELP: setenv ( obj n -- )
-{ $values { "n" "a non-negative integer" } { "obj" object } }
+{ $values { "obj" object } { "n" "a non-negative integer" } }
{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
HELP: object
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
-: 2tri@ ( u v w y x z quot -- )
+: 2tri@ ( u v w x y z quot -- )
dup dup 2tri* ; inline
! Quotation building
math.order kernel.private ;
IN: layouts
+SYMBOL: data-alignment
+
SYMBOL: tag-mask
SYMBOL: num-tags
IN: math.parser
: digit> ( ch -- n )
- H{
- { CHAR: 0 0 }
- { CHAR: 1 1 }
- { CHAR: 2 2 }
- { CHAR: 3 3 }
- { CHAR: 4 4 }
- { CHAR: 5 5 }
- { CHAR: 6 6 }
- { CHAR: 7 7 }
- { CHAR: 8 8 }
- { CHAR: 9 9 }
- { CHAR: A 10 }
- { CHAR: B 11 }
- { CHAR: C 12 }
- { CHAR: D 13 }
- { CHAR: E 14 }
- { CHAR: F 15 }
- { CHAR: a 10 }
- { CHAR: b 11 }
- { CHAR: c 12 }
- { CHAR: d 13 }
- { CHAR: e 14 }
- { CHAR: f 15 }
- { CHAR: , f }
- } at* [ drop 255 ] unless ; inline
+ 127 bitand {
+ { [ dup CHAR: 9 <= ] [ CHAR: 0 - ] }
+ { [ dup CHAR: a < ] [ CHAR: A 10 - - ] }
+ [ CHAR: a 10 - - ]
+ } cond
+ dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline
: string>digits ( str -- digits )
[ digit> ] B{ } map-as ; inline
: (digits>integer) ( valid? accum digit radix -- valid? accum )
- over [
- 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
- ] [ 2drop ] if ; inline
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
: string>natural ( seq radix -- n/f )
over empty? [ 2drop f ] [
- [ [ digit> ] dip (digits>integer) ] each-digit
- ] if ; inline
+ [ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit
+ ] if ;
: sign ( -- str ) negative? get "-" "+" ? ;
] if ; inline
: dec>float ( str -- n/f )
- [ CHAR: , eq? not ] filter
- >byte-array 0 suffix (string>float) ;
+ [ CHAR: , eq? not ] BV{ } filter-as
+ 0 over push B{ } like (string>float) ;
: hex>float-parts ( str -- neg? mantissa-str expt )
"-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
{
{ 16 [ hex>float ] }
[ drop dec>float ]
- } case ;
+ } case ; inline
: number-char? ( char -- ? )
- "0123456789ABCDEFabcdef." member? ;
+ "0123456789ABCDEFabcdef." member? ; inline
+
+: last-unsafe ( seq -- elt )
+ [ length 1 - ] [ nth-unsafe ] bi ; inline
: numeric-looking? ( str -- ? )
- "-" ?head drop
dup empty? [ drop f ] [
- dup first number-char? [
- last number-char?
- ] [ drop f ] if
- ] if ;
+ dup first-unsafe number-char? [
+ last-unsafe number-char?
+ ] [
+ dup first-unsafe CHAR: - eq? [
+ dup length 1 eq? [ drop f ] [
+ 1 over nth-unsafe number-char? [
+ last-unsafe number-char?
+ ] [ drop f ] if
+ ] if
+ ] [ drop f ] if
+ ] if
+ ] if ; inline
PRIVATE>
: string>float ( str -- n/f )
- 10 base>float ;
+ 10 base>float ; inline
: base> ( str radix -- n/f )
over numeric-looking? [
} case
] [ 2drop f ] if ;
-: string>number ( str -- n/f ) 10 base> ;
-: bin> ( str -- n/f ) 2 base> ;
-: oct> ( str -- n/f ) 8 base> ;
-: hex> ( str -- n/f ) 16 base> ;
+: string>number ( str -- n/f ) 10 base> ; inline
+: bin> ( str -- n/f ) 2 base> ; inline
+: oct> ( str -- n/f ) 8 base> ; inline
+: hex> ( str -- n/f ) 16 base> ; inline
: >digit ( n -- ch )
- dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
+ dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
: positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when
{
{ 16 [ float>hex ] }
[ drop float>decimal ]
- } case ;
+ } case ; inline
PRIVATE>
: float>string ( n -- str )
- 10 float>base ;
+ 10 float>base ; inline
M: float >base
{
[ float>base ]
} cond ;
-: number>string ( n -- str ) 10 >base ;
-: >bin ( n -- str ) 2 >base ;
-: >oct ( n -- str ) 8 >base ;
-: >hex ( n -- str ) 16 >base ;
+: number>string ( n -- str ) 10 >base ; inline
+: >bin ( n -- str ) 2 >base ; inline
+: >oct ( n -- str ) 8 >base ; inline
+: >hex ( n -- str ) 16 >base ; inline
-: # ( n -- ) number>string % ;
+: # ( n -- ) number>string % ; inline
{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
-{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } }
+{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } }
{ $description "Reads an integer in a specific numerical base from the parser input." }
$parsing-note ;
dup string? [ dup length sbuf boa ] [ >sbuf ] if
] unless ; inline
-M: sbuf new-resizable drop <sbuf> ; inline
-
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
M: string new-resizable drop <sbuf> ; inline
+M: sbuf new-resizable drop <sbuf> ; inline
+
M: string like
#! If we have a string, we're done.
#! If we have an sbuf, and it's at full capacity, we're done.
{ $description "Creates a three-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: 4sequence
-{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "obj3" object } { "obj4" object } { "seq" sequence } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a four-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: first2
} } ;
HELP: accumulate-as
-{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ;
HELP: accumulate
-{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
-{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
+HELP: filter-as
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
+{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
+
HELP: filter-here
{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
} } ;
HELP: move
-{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
+{ $values { "to" "an index in " { $snippet "seq" } } { "from" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
{ $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." }
{ $side-effects "seq" } ;
{ $side-effects "seq" } ;
HELP: replace-slice
-{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
+{ $values { "new" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ;
"Filtering:"
{ $subsections
filter
+ filter-as
partition
}
"Testing if a sequence contains elements satisfying a predicate:"
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
+: pusher-for ( quot exemplar -- quot accum )
+ [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
+
: pusher ( quot -- quot accum )
- V{ } clone [ [ push-if ] 2curry ] keep ; inline
+ V{ } pusher-for ; inline
+
+: filter-as ( seq quot exemplar -- subseq )
+ dup [ pusher-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq )
- over [ pusher [ each ] dip ] dip like ; inline
+ over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
: partition ( seq quot -- trueseq falseseq )
over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
+: accumulator-for ( quot exemplar -- quot' vec )
+ [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline
+
: accumulator ( quot -- quot' vec )
- V{ } clone [ [ push ] curry compose ] keep ; inline
+ V{ } accumulator-for ; inline
: produce-as ( pred quot exemplar -- seq )
- [ accumulator [ while ] dip ] dip like ; inline
+ dup [ accumulator-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq )
{ } produce-as ; inline
M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
[ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
} ;
HELP: record-checksum
-{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
+{ $values { "lines" "a sequence of strings" } { "source-file" source-file } }
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays combinators effects.parser fry generalizations grouping kernel
-lexer locals macros make math math.ranges parser sequences sequences.private ;
+lexer locals macros make math math.ranges parser sequences
+sequences.generalizations sequences.private ;
FROM: alien.arrays => array-length ;
IN: alien.data.map
-USING: math kernel alien ;\r
+USING: math kernel alien alien.c-types ;\r
IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
- "int" { "int" } "cdecl" [\r
+ int { int } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
1 - dup fib swap 1 - fib +\r
] if\r
] alien-callback\r
- "int" { "int" } "cdecl" alien-indirect ;\r
+ int { int } "cdecl" alien-indirect ;\r
\r
: fib-main ( -- ) 32 fib drop ;\r
\r
quotations
sequences
sequences.deep
- syntax
words
;
IN: cpu.8080.emulator
[ f ] [ D: -1 D: -2 before? ] unit-test
[ f ] [ D: -2 D: -2 before? ] unit-test
[ t ] [ D: -3 D: -2 before? ] unit-test
+[ t ] [ D: .5 D: 0 D: 1.0 between? ] unit-test
] 2bi ;
: scale-decimals ( D1 D2 -- D1' D2' )
- [ drop ]
- [ scale-mantissas <decimal> nip ] 2bi ;
+ scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
ERROR: decimal-types-expected d1 d2 ;
e1
e2 a + - <decimal> ;
+
+M: decimal <=>
+ 2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline
combinators.short-circuit game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
-io io.encodings.ascii io.files io.files.temp kernel math
-math.matrices math.parser math.vectors method-chains sequences
-splitting threads ui ui.gadgets ui.gadgets.worlds
-ui.pixel-formats specialized-arrays specialized-vectors ;
+io io.encodings.ascii io.files io.files.temp kernel locals math
+math.matrices math.vectors.simd math.parser math.vectors
+method-chains namespaces sequences splitting threads ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats specialized-arrays
+specialized-vectors ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
+SIMD: float
IN: gpu.demos.bunny
GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
{ f float-components 1 f }
{ "normal" float-components 3 f }
{ f float-components 1 f } ;
-VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+
+STRUCT: bunny-vertex-struct
+ { vertex float-4 }
+ { normal float-4 } ;
SPECIALIZED-VECTOR: bunny-vertex-struct
{ "texcoord-scale" vec2-uniform f }
{ "loading-texture" texture-uniform f } ;
-: numbers ( str -- seq )
- " " split [ string>number ] map sift ;
+: numbers ( tokens -- seq )
+ [ string>number ] map ; inline
: <bunny-vertex> ( vertex -- struct )
bunny-vertex-struct <struct>
- swap >float-array >>vertex ; inline
+ swap first3 0.0 float-4-boa >>vertex ; inline
+
+: (read-line-tokens) ( seq stream -- seq )
+ " \n" over stream-read-until
+ [ [ pick push ] unless-empty ]
+ [
+ {
+ { CHAR: \s [ (read-line-tokens) ] }
+ { CHAR: \n [ drop ] }
+ [ 2drop [ f ] when-empty ]
+ } case
+ ] bi* ; inline recursive
+
+: stream-read-line-tokens ( stream -- seq )
+ V{ } clone swap (read-line-tokens) ;
+
+: each-line-tokens ( quot -- )
+ input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline
: (parse-bunny-model) ( vs is -- vs is )
- readln [
+ [
numbers {
- { [ dup length 5 = ] [ 3 head <bunny-vertex> pick push ] }
+ { [ dup length 5 = ] [ <bunny-vertex> pick push ] }
{ [ dup first 3 = ] [ rest over push-all ] }
[ drop ]
- } cond (parse-bunny-model)
- ] when* ;
+ } cond
+ ] each-line-tokens ; inline
: parse-bunny-model ( -- vertexes indexes )
100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
- (parse-bunny-model) ;
+ (parse-bunny-model) ; inline
-: normal ( vertexes -- normal )
- [ [ second ] [ first ] bi v- ]
- [ [ third ] [ first ] bi v- ] bi cross
- vneg normalize ; inline
+:: normal ( a b c -- normal )
+ c a v-
+ b a v- cross normalize ; inline
-: calc-bunny-normal ( vertexes indexes -- )
- swap
- [ [ nth vertex>> ] curry { } map-as normal ]
- [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
+:: calc-bunny-normal ( a b c vertexes -- )
+ a b c [ vertexes nth vertex>> ] tri@ normal :> n
+ a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline
: calc-bunny-normals ( vertexes indexes -- )
- 3 <groups>
- [ calc-bunny-normal ] with each ;
+ 3 <sliced-groups> swap
+ [ [ first3 ] dip calc-bunny-normal ] curry each ; inline
: normalize-bunny-normals ( vertexes -- )
- [ [ normalize ] change-normal drop ] each ;
+ [ [ normalize ] change-normal drop ] each ; inline
: bunny-data ( filename -- vertexes indexes )
ascii [ parse-bunny-model ] with-file-reader
] [ nip ] if ":" join ;
: replace-log-line-numbers ( object log -- log' )
- "\n" split [ empty? not ] filter
+ "\n" split harvest
[ replace-log-line-number ] with map
"\n" join ;
{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
HELP: fold
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
+{ $values { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } }
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
HELP: switch-models
"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
-ABOUT: "models.combinators"
\ No newline at end of file
+ABOUT: "models.combinators"
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup modules.rpc-server modules.using ;
-IN: modules.rpc-server
-HELP: service
-{ $syntax "IN: my-vocab service" }
-{ $description "Allows words defined in the vocabulary to be used as remote procedure calls by " { $link POSTPONE: USING*: } } ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators continuations effects
-io.encodings.binary io.servers.connection kernel namespaces
-sequences serialize sets threads vocabs vocabs.parser init io ;
-IN: modules.rpc-server
-
-<PRIVATE
-TUPLE: rpc-request args vocabspec wordname ;
-SYMBOL: serving-vocabs serving-vocabs [ V{ } clone ] initialize
-
-: getter ( -- ) deserialize dup serving-vocabs get-global index
- [ vocab-words [ stack-effect ] { } assoc-map-as ]
- [ \ no-vocab boa ] if serialize flush ;
-
-: doer ( -- ) deserialize dup vocabspec>> serving-vocabs get-global index
- [ [ args>> ] [ wordname>> ] [ vocabspec>> vocab-words ] tri at [ execute ] curry with-datastack ]
- [ vocabspec>> \ no-vocab boa ] if serialize flush ;
-
-PRIVATE>
-SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
-
-: start-rpc-server ( -- )
- binary <threaded-server>
- "rpcs" >>name 9012 >>insecure
- [ deserialize {
- { "getter" [ getter ] }
- { "doer" [ doer ] }
- { "loader" [ deserialize vocab serialize flush ] }
- } case ] >>handler
- start-server ;
+++ /dev/null
-Serve factor words as rpcs
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: modules.rpc
-ARTICLE: { "modules" "protocol" } "RPC Protocol"
-{ $list
- "Send vocab as string"
- "Send arglist"
- "Send word as string"
- "Receive result list"
-} ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry generalizations io.encodings.binary
-io.sockets kernel locals namespaces parser sequences serialize
-vocabs vocabs.parser words io ;
-IN: modules.rpc
-
-TUPLE: rpc-request args vocabspec wordname ;
-
-: send-with-check ( message -- reply/* )
- serialize flush deserialize dup no-vocab? [ throw ] when ;
-
-:: define-remote ( str effect addrspec vocabspec -- )
- str create-in effect [ in>> length ] [ out>> length ] bi
- '[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary
- [ "doer" serialize send-with-check ] with-client _ firstn ]
- effect define-declared ;
-
-:: remote-vocab ( addrspec vocabspec -- vocab )
- vocabspec "-remote" append dup vocab [ dup set-current-vocab
- vocabspec addrspec 9012 <inet> binary [ "getter" serialize send-with-check ] with-client
- [ first2 addrspec vocabspec define-remote ] each
- ] unless ;
-
-: remote-load ( addr vocabspec -- voabspec ) [ swap
- 9012 <inet> binary [ "loader" serialize serialize flush deserialize ] with-client ] keep
- [ dictionary get-global set-at ] keep ;
\ No newline at end of file
+++ /dev/null
-remote procedure call client
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-Improved module import syntax with network transparency
\ No newline at end of file
+++ /dev/null
-USING: help.syntax help.markup strings modules.using ;
-IN: modules.using
-ARTICLE: { "modules.using" "use" } "Using the modules.using vocab"
-"This vocabulary defines " { $link POSTPONE: USING*: } " as an alternative to " { $link POSTPONE: USING: } " which makes qualified imports easier. "
-"Secondly, it allows loading vocabularies from remote servers, as long as the remote vocabulary can be accessed at compile time. "
-"Finally, the word can treat words in remote vocabularies as remote procedure calls. Any inputs are passed to the imported words as normal, and the result will appear on the stack- the only difference is that the word isn't called locally." ;
-ABOUT: { "modules.using" "use" }
-
-HELP: USING*:
-{ $syntax "USING: rpc-server::module fetch-sever:module { module qualified-name } { module => word ... } { qualified-module } { module EXCEPT word ... } { module word => importname } ;" }
-{ $description "Adds vocabularies to the search path. Vocabularies can be loaded off a server or called as an rpc if preceded by a valid hostname. Bracketed pairs facilitate all types of qualified imports on both remote and local modules." } ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel modules.rpc peg peg-lexer peg.ebnf sequences
-strings vocabs.parser ;
-IN: modules.using
-
-EBNF: modulize
-tokenpart = (!(':').)+ => [[ >string ]]
-s = ':' => [[ drop ignore ]]
-rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
-remote = tokenpart s tokenpart => [[ first2 remote-load ]]
-module = rpc | remote | tokenpart
-;EBNF
-
-ON-BNF: USING*:
-tokenizer = <foreign factor>
-sym = !(";"|"}"|"=>"|"EXCEPT").
-modspec = sym => [[ modulize ]]
-qualified-with = modspec sym => [[ first2 add-qualified ignore ]]
-qualified = modspec => [[ dup add-qualified ignore ]]
-from = modspec "=>" sym+ => [[ first3 nip add-words-from ignore ]]
-exclude = modspec "EXCEPT" sym+ => [[ first3 nip add-words-excluding ignore ]]
-rename = modspec sym "=>" sym => [[ first4 nip swapd add-renamed-word ignore ]]
-long = "{" ( from | exclude | rename | qualified-with | qualified ) "}" => [[ drop ignore ]]
-short = modspec => [[ use-vocab ignore ]]
-wordSpec = long | short
-using = wordSpec+ ";" => [[ drop ignore ]]
-;ON-BNF
\ No newline at end of file
: asc ( key -- spec ) 1 2array ; inline
: desc ( key -- spec ) -1 2array ; inline
-GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
-
-M: mdb-query-msg sort
+: sort ( mdb-query-msg sort-quot -- mdb-query-msg )
output>array [ 1array >hashtable ] map >>orderby ; inline
: key-spec ( spec-quot -- spec-assoc )
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ;
-! XXX doesn't work for NaNs or floats > 2^31
+! XXX doesn't work when v is nan or |v| >= 2^31
: floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: peg.ebnf help.syntax help.markup strings ;
-IN: peg-lexer
-
-HELP: ON-BNF:
-{ $syntax "ON-BNF: word ... ;ON-BNF" }
-{ $description "Creates a parsing word using a parser for lexer control, adding the resulting ast to the stack. Parser syntax is as in " { $link POSTPONE: EBNF: } } ;
-
-HELP: create-bnf
-{ $values { "name" string } { "parser" parser } }
-{ $description "Runtime equivalent of " { $link POSTPONE: ON-BNF: } " also useful with manually constructed parsers." } ;
-
-HELP: factor
-{ $values { "input" string } { "ast" "a sequence of tokens" } }
-{ $description "Tokenizer that acts like standard factor lexer, separating tokens by whitespace." } ;
\ No newline at end of file
+++ /dev/null
-USING: tools.test peg-lexer.test-parsers ;
-IN: peg-lexer.tests
-
-{ V{ "1234" "-end" } } [
- test1 1234-end
-] unit-test
-
-{ V{ 1234 53 } } [
- test2 12345
-] unit-test
-
-{ V{ "heavy" "duty" "testing" } } [
- test3 heavy duty testing
-] unit-test
\ No newline at end of file
+++ /dev/null
-USING: hashtables assocs sequences locals math accessors multiline delegate strings
-delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
-words ;
-IN: peg-lexer
-
-TUPLE: lex-hash hash ;
-CONSULT: assoc-protocol lex-hash hash>> ;
-: <lex-hash> ( a -- lex-hash ) lex-hash boa ;
-
-: pos-or-0 ( neg? -- pos/0 ) dup 0 < [ drop 0 ] when ;
-
-:: prepare-pos ( v i -- c l )
- [let | n [ i v head-slice ] |
- v CHAR: \n n last-index -1 or 1 + -
- n [ CHAR: \n = ] count 1 +
- ] ;
-
-: store-pos ( v a -- )
- input swap at prepare-pos
- lexer get [ (>>line) ] keep (>>column) ;
-
-M: lex-hash set-at
- swap {
- { pos [ store-pos ] }
- [ swap hash>> set-at ]
- } case ;
-
-:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ;
-
-M: lex-hash at*
- swap {
- { input [ drop lexer get text>> "\n" join t ] }
- { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
- [ swap hash>> at* ]
- } case ;
-
-: with-global-lexer ( quot -- result )
- [
- f lrstack set
- V{ } clone error-stack set H{ } clone \ heads set
- H{ } clone \ packrat set
- ] f make-assoc <lex-hash>
- swap bind ; inline
-
-: parse* ( parser -- ast )
- compile
- [ execute [ error-stack get first throw ] unless* ] with-global-lexer
- ast>> ; inline
-
-: create-bnf ( name parser -- )
- reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
- define-syntax word make-inline ;
-
-SYNTAX: ON-BNF:
- CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
- main swap at create-bnf ;
-
-! Tokenizer like standard factor lexer
-EBNF: factor
-space = " " | "\n" | "\t"
-spaces = space* => [[ drop ignore ]]
-chunk = (!(space) .)+ => [[ >string ]]
-expr = spaces chunk
-;EBNF
+++ /dev/null
-Use peg to write parsing words
+++ /dev/null
-extensions
-reflection
+++ /dev/null
-USING: peg-lexer math.parser strings ;
-IN: peg-lexer.test-parsers
-
-ON-BNF: test1
- num = [1-4]* => [[ >string ]]
- expr = num ( "-end" | "-done" )
-;ON-BNF
-
-ON-BNF: test2
- num = [1-4]* => [[ >string string>number ]]
- expr= num [5-9]
-;ON-BNF
-
-ON-BNF: test3
- tokenizer = <foreign factor>
- expr= "heavy" "duty" "testing"
-;ON-BNF
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
- accessors sequences math peg.ebnf ;
+ accessors sequences math peg.ebnf peg.ebnf.private ;
IN: peg.javascript.parser.tests
{
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf peg.pl0
+USING: kernel tools.test peg peg.ebnf peg.ebnf.private peg.pl0
sequences accessors ;
IN: peg.pl0.tests
--- /dev/null
+Elie Chaftari
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs help.markup help.syntax kernel math
+sequences strings ;
+IN: pop3
+
+HELP: <pop3-account>
+{ $values
+
+ { "pop3-account" pop3-account }
+}
+{ $description "creates a " { $link pop3-account } " object with defaults for the port and timeout slots." } ;
+
+HELP: account
+{ $values
+
+ { "pop3-account" pop3-account }
+}
+{ $description "You only need to call " { $link connect } " after calling this word to reconnect to the latest accessed POP3 account." }
+{ $examples
+ { $code
+ "account connect"
+ ""
+ }
+} ;
+
+HELP: >user
+{ $values
+ { "name" "userID of the account" }
+}
+{ $description "Sends the userID of the account on the POP3 server (this could be the full e-mail address)" $nl
+"This must be the first command after " { $link connect } " if username and password have not been set with " { $link <pop3-account> } "."
+} ;
+
+HELP: >pwd
+{ $values
+ { "password" "password for the userID" }
+}
+{ $description "Sends the clear-text password for the userID. The password may be case sensitive. This must be the next command after " { $link >user } "." } ;
+
+HELP: capa
+{ $values
+
+ { "array" array }
+}
+{ $description "Queries the mail server capabilities, as described in RFC 2449. It is advised to check for command support before calling the appropriate words (e.g. TOP UIDL)." } ;
+
+HELP: connect
+{ $values
+ { "pop3-account" pop3-account }
+}
+{ $description "Opens a network connection to the pop3 mail server with the settings given in the pop3-account slots." }
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ " \"username@yourisp.com\" >>user"
+ " \"pass123\" >>pwd"
+ "connect"
+ ""
+ }
+} ;
+
+HELP: consolidate
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Builds a sequence of email tuples, iterating over each email top and consolidating its headers with its number, uidl, and size." } ;
+
+HELP: delete
+{ $values
+ { "message#" fixnum }
+}
+{ $description "This marks message number message# for deletion from the server. This is the way to get rid of a problem causing message. It is not actually deleted until the " { $link close } " word is issued. If you lose the connection to the mail server before calling the " { $link close } " word, the server should not delete any messages. Example: 3 delete" } ;
+
+HELP: headers
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Gathers and associates the From:, Subject:, and To: headers of each message." } ;
+
+HELP: list
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Lists each message with its number and size in bytes" } ;
+
+HELP: pop3-account
+{ $class-description "A POP3 account on a POP3 server. It has the following slots:"
+ { $table
+ { { $slot "#" } "The ephemeral ordinal number of the message." }
+ { { $slot "host" } "The name or IP address of the remote host to which a POP3 connection is required." }
+ { { $slot "port" } "The POP3 server port (defaults to 110)." }
+ { { $slot "timeout" } "Maximum time in minutes to wait for a response from the POP3 server (defaults to 1 minutes)." }
+ { { $slot "user" } "The userID of the account on the POP3 server." }
+ { { $slot "pwd" } { "The clear-text password for the userID." } }
+ { { $slot "stream" } { "The duplex input/output stream wrapping the POP3 session." } }
+ { { $slot "capa" } { "A list of the mail server capabilities." } }
+ { { $slot "count" } { "Number of messages in the mailbox." } }
+ { { $slot "list" } { "A list of every message with its number and size in bytes" } }
+ { { $slot "uidls" } { "The UIDL (Unique IDentification Listing) of every message in the mailbox together with its ordinal number." } }
+ { { $slot "messages" } { "A sequence of email tuples in the mailbox containing each email's headers, number, uidl, and size." } }
+ }
+"The " { $slot "host" } " is required; the rest are either set by default or optional." $nl
+"The " { $slot "user" } " and " { $slot "pwd" } " must either be set before using " { $link connect } " or immediately after it with the " { $link >user } " and " { $link >pwd } " words."
+} ;
+
+HELP: message
+{ $class-description "An e-mail message having the following slots:"
+ { $table
+ { { $slot "#" } "The ephemeral ordinal number of the message." }
+ { { $slot "uidl" } "The POP3 UIDL (Unique IDentification Listing) of the message." }
+ { { $slot "headers" } "The From:, Subject:, and To: headers of the message." }
+ { { $slot "from" } "The sender of the message. An e-mail address." }
+ { { $slot "to" } "The recipients of the message." }
+ { { $slot "subject" } { "The subject of the message." } }
+ { { $slot "size" } { "The size of the message in octets." } }
+ }
+} ;
+
+HELP: close
+{ $description "Deletes any messages marked for deletion, and then logs you off of the mail server. This is the last command to use." } ;
+
+HELP: retrieve
+{ $values
+ { "message#" fixnum }
+ { "seq" sequence }
+}
+{ $description "Sends message number message# to you. You should prepare for some base64 decoding. You probably want to do this with a mailer." } ;
+
+HELP: reset
+{ $description "Resets the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted." } ;
+
+HELP: count
+{ $values
+
+ { "n" fixnum }
+}
+{ $description "Gets the number of messages in the mailbox." } ;
+
+HELP: top
+{ $values
+ { "message#" fixnum } { "#lines" fixnum }
+ { "seq" sequence }
+}
+{ $description "Lists the header for message# and the first #lines of the message text. For example, 1 0 top would list just the headers for message 1, where as 1 5 top would list the headers and first 5 lines of the message text." } ;
+
+HELP: uidl
+{ $values
+ { "message#" fixnum }
+ { "uidl" string }
+}
+{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of the given message#." } ;
+
+HELP: uidls
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of every specific message in the mailbox together with its ordinal number. UIDL provides a mechanism that avoids numbering issues between POP3 sessions by assigning a permanent and unique ID for each message." } ;
+
+ARTICLE: "pop3" "POP3 client library"
+"The " { $vocab-link "pop3" } " vocab implements a client interface to the POP3 protocol, enabling a Factor application to talk to POP3 servers. It allows interactive sessions similar to telnet ones to do maintenance on your mailbox on a POP3 mail server; to look at, and possibly delete, any problem causing message (e.g. too large, improperly formatted, etc.)." $nl
+"Word names do not necessarily map directly to POP3 commands defined in RFC1081 or RFC1939, although most commands are supported." $nl
+"This article assumes that you are familiar with the POP3 protocol."
+$nl
+"Connecting to the mail server:"
+{ $subsections connect }
+"You need to construct a pop3-account tuple first, setting at least the host slot."
+{ $subsections <pop3-account> }
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ " \"username@yourisp.com\" >>user"
+ " \"pass123\" >>pwd"
+ "connect"
+ ""
+ }
+}
+$nl
+"If you do not supply the username or password, you will need to call the " { $link >user } " and " { $link >pwd } " vocabs in this order after the " { $link connect } " vocab."
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ "connect"
+ ""
+ "\"username@yourisp.com\" >user"
+ "\"pass123\" >pwd"
+ ""
+ }
+}
+$nl
+{ $notes "Subsequent calls to the " { $link pop3-account } " thus created can be done by calling the " { $link account } " word. If you needed to reconnect to the same POP3 account after having called " { $link close } ", you only need to call " { $link account } " followed by " { $link connect } "." }
+$nl
+"Querying the mail server:"
+$nl
+"For its capabilities:"
+{ $subsections capa }
+{ $examples
+ { $code
+ "capa ."
+ "{ \"CAPA\" \"TOP\" \"UIDL\" }"
+ ""
+ }
+}
+$nl
+"For the message count:"
+{ $subsections count }
+{ $examples
+ { $code
+ "count ."
+ "2"
+ ""
+ }
+}
+$nl
+"For each message's size:"
+{ $subsections list }
+{ $examples
+ { $code
+ "list ."
+ "H{ { 1 \"1006\" } { 2 \"747\" } }"
+ ""
+ }
+}
+$nl
+"For a specific message raw header, appropriate headers, or number of lines:"
+{ $subsections top }
+{ $examples
+ { $code
+ "1 0 top ."
+ "<the raw-source of the message header is retrieved>"
+ ""
+ }
+ { $code
+ "1 5 top ."
+ "<the raw-source of the message header and its first 5 lines are retrieved>"
+ ""
+ }
+ { $code
+ "1 0 top headers ."
+ "H{"
+ " { \"From:\" \"from@mail.com\" }"
+ " { \"Subject:\" \"Re:\" }"
+ " { \"To:\" \"username@host.com\" }"
+ "}"
+ ""
+ }
+}
+$nl
+"To consolidate all the messages of this account into a single association:"
+{ $subsections consolidate }
+{ $examples
+ { $code
+ "consolidate ."
+"""{
+ T{ message
+ { # 1 }
+ { uidl \"000000d547ac2fc2\" }
+ { from \"from.first@mail.com\" }
+ { to \"username@host.com\" }
+ { subject \"First subject\" }
+ { size \"1006\" }
+ }
+ T{ message
+ { # 2 }
+ { uidl \"000000d647ac2fc2\" }
+ { from \"from.second@mail.com\" }
+ { to \"username@host.com\" }
+ { subject \"Second subject\" }
+ { size \"747\" }
+ }
+}"""
+ ""
+ }
+}
+$nl
+"You may want to delete message #2 but want to make sure you are deleting the right one. You can check that message #2 has the uidl from the example above."
+{ $subsections uidl }
+{ $examples
+ { $code
+ "2 uidl ."
+ "\"000000d647ac2fc2\""
+ ""
+ }
+}
+$nl
+"Now with your mind at rest, you can delete message #2. The message is marked for deletion."
+{ $subsections delete }
+{ $examples
+ { $code
+ "2 delete"
+ ""
+ }
+}
+$nl
+"The messages marked for deletion are actually deleted only when " { $link close } " is called. This should be the last command you issue. "
+{ $subsections close }
+{ $examples
+ { $code
+ "close"
+ ""
+ }
+}
+{ $notes "If you change your mind at any point, you can call " { $link reset } " to reset the status of all messages to not be deleted." } ;
+
+ABOUT: "pop3"
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises namespaces kernel pop3 pop3.server
+sequences tools.test accessors ;
+IN: pop3.tests
+
+FROM: pop3 => count delete ;
+
+<promise> "p1" set
+
+[ ] [ "p1" get mock-pop3-server ] unit-test
+[ ] [
+ <pop3-account>
+ "127.0.0.1" >>host
+ "p1" get ?promise >>port
+ connect
+] unit-test
+[ ] [ "username@host.com" >user ] unit-test
+[ ] [ "password" >pwd ] unit-test
+[ { "CAPA" "TOP" "UIDL" } ] [ capa ] unit-test
+[ 2 ] [ count ] unit-test
+[ H{ { 1 "1006" } { 2 "747" } } ] [ list ] unit-test
+[
+ H{
+ { "From:" "from.first@mail.com" }
+ { "Subject:" "First test with mock POP3 server" }
+ { "To:" "username@host.com" }
+ }
+] [ 1 0 top drop headers ] unit-test
+[
+ {
+ T{ message
+ { # 1 }
+ { uidl "000000d547ac2fc2" }
+ { from "from.first@mail.com" }
+ { to "username@host.com" }
+ { subject "First test with mock POP3 server" }
+ { size "1006" }
+ }
+ T{ message
+ { # 2 }
+ { uidl "000000d647ac2fc2" }
+ { from "from.second@mail.com" }
+ { to "username@host.com" }
+ { subject "Second test with mock POP3 server" }
+ { size "747" }
+ }
+ }
+] [ consolidate ] unit-test
+[ "000000d547ac2fc2" ] [ 1 uidl ] unit-test
+[ ] [ 1 delete ] unit-test
+[ ] [ reset ] unit-test
+[ ] [ close ] unit-test
+
+
+<promise> "p2" set
+
+[ ] [ "p2" get mock-pop3-server ] unit-test
+[ ] [
+ <pop3-account>
+ "127.0.0.1" >>host
+ "p2" get ?promise >>port
+ "username@host.com" >>user
+ "password" >>pwd
+ connect
+] unit-test
+[ f ] [ 1 retrieve empty? ] unit-test
+[ ] [ close ] unit-test
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors annotations arrays assocs calendar combinators
+fry hashtables io io.crlf io.encodings.utf8 io.sockets
+io.streams.duplex io.timeouts kernel make math math.parser
+math.ranges namespaces prettyprint sequences splitting
+strings ;
+IN: pop3
+
+TUPLE: pop3-account
+# host port timeout user pwd stream capa count list
+uidls messages ;
+
+: <pop3-account> ( -- pop3-account )
+ pop3-account new
+ 110 >>port
+ 1 minutes >>timeout ;
+
+: account ( -- pop3-account ) pop3-account get ;
+
+TUPLE: message # uidl headers from to subject size ;
+
+<PRIVATE
+
+: stream ( -- duplex-stream ) account stream>> ;
+
+: <message> ( -- message ) message new ; inline
+
+TUPLE: raw-source top headers content ;
+
+: <raw-source> ( -- raw-source ) raw-source new ; inline
+
+: raw ( -- raw-source ) raw-source get ;
+
+: set-read-timeout ( -- )
+ stream [
+ account timeout>> timeouts
+ ] with-stream* ;
+
+: get-ok ( -- )
+ stream [
+ readln dup "+OK" head? [ drop ] [ throw ] if
+ ] with-stream* ;
+
+: get-ok-and-total ( -- total )
+ stream [
+ readln dup "+OK" head? [
+ " " split second string>number dup account (>>count)
+ ] [ throw ] if
+ ] with-stream* ;
+
+: get-ok-and-uidl ( -- uidl )
+ stream [
+ readln dup "+OK" head? [
+ " " split last
+ ] [ throw ] if
+ ] with-stream* ;
+
+: command ( string -- ) write crlf flush get-ok ;
+
+: command-and-total ( string -- total ) write crlf flush
+ get-ok-and-total ;
+
+: command-and-uidl ( string -- uidl ) write crlf flush
+ get-ok-and-uidl ;
+
+: associate-split ( seq -- assoc )
+ [ " " split1 ] H{ } map>assoc ;
+
+: split-map ( seq -- assoc )
+ associate-split [ [ string>number ] dip ] assoc-map ;
+
+: (readlns) ( -- )
+ readln dup "." = [ , ] dip [ (readlns) ] unless ;
+
+: readlns ( -- seq ) [ (readlns) ] { } make but-last ;
+
+: (list) ( -- )
+ stream [
+ "LIST" command
+ readlns account (>>list)
+ ] with-stream* ;
+
+: (uidls) ( -- )
+ stream [
+ "UIDL" command
+ readlns account (>>uidls)
+ ] with-stream* ;
+
+PRIVATE>
+
+: >user ( name -- )
+ [ stream ] dip '[
+ "USER " _ append command
+ ] with-stream* ;
+
+: >pwd ( password -- )
+ [ stream ] dip '[
+ "PASS " _ append command
+ ] with-stream* ;
+
+: connect ( pop3-account -- )
+ [
+ [ host>> ] [ port>> ] bi
+ <inet> utf8 <client> drop
+ ] keep swap >>stream
+ {
+ [ pop3-account set ]
+ [ user>> [ >user ] when* ]
+ [ pwd>> [ >pwd ] when* ]
+ } cleave
+ set-read-timeout
+ get-ok ;
+
+: capa ( -- array )
+ stream [
+ "CAPA" command
+ readlns dup account (>>capa)
+ ] with-stream* ;
+
+: count ( -- n )
+ stream [
+ "STAT" command-and-total
+ ] with-stream* ;
+
+: list ( -- assoc )
+ (list) account list>> split-map ;
+
+: uidl ( message# -- uidl )
+ [ stream ] dip '[
+ "UIDL " _ number>string append command-and-uidl
+ ] with-stream* ;
+
+: uidls ( -- assoc )
+ (uidls) account uidls>> split-map ;
+
+: top ( message# #lines -- seq )
+ <raw-source> raw-source set
+ [ stream ] 2dip '[
+ "TOP " _ number>string append " "
+ append _ number>string append
+ command
+ readlns dup raw (>>top)
+ ] with-stream* ;
+
+: headers ( -- assoc )
+ raw top>> {
+ [
+ [ dup "From:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ [
+ [ dup "To:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ [
+ [ dup "Subject:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ } cleave raw headers>> associate-split ;
+
+: retrieve ( message# -- seq )
+ [ stream ] dip '[
+ "RETR " _ number>string append command
+ readlns dup raw (>>content)
+ ] with-stream* ;
+
+: delete ( message# -- )
+ [ stream ] dip '[
+ "DELE " _ number>string append command
+ ] with-stream* ;
+
+: reset ( -- )
+ stream [ "RSET" command ] with-stream* ;
+
+: consolidate ( -- seq )
+ count zero? [ "No mail for account." ] [
+ 1 account count>> [a,b] [
+ {
+ [ 0 top drop ]
+ [ <message> swap >># ]
+ [ uidls at >>uidl ]
+ [ list at >>size ]
+ } cleave
+ "From:" headers at >>from
+ "To:" headers at >>to
+ "Subject:" headers at >>subject
+ account [ swap suffix ] change-messages drop
+ ] each account messages>>
+ ] if ;
+
+: close ( -- )
+ stream [ "QUIT" command ] with-stream ;
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar combinators concurrency.promises
+destructors fry io io.crlf io.encodings.utf8 io.sockets
+io.sockets.secure.unix.debug io.streams.duplex io.timeouts
+kernel locals math.parser namespaces prettyprint sequences
+splitting threads ;
+IN: pop3.server
+
+! Mock POP3 server for testing purposes.
+
+! $ telnet 127.0.0.1 (start-pop3-server outputs listening port)
+! Trying 127.0.0.1...
+! Connected to localhost.
+! Escape character is '^]'.
+! +OK POP3 server ready
+! USER username@host.com
+! +OK Password required
+! PASS password
+! +OK Logged in
+! STAT
+! +OK 2 1753
+! LIST
+! +OK 2 messages:
+! 1 1006
+! 2 747
+! .
+! UIDL 1
+! +OK 1 000000d547ac2fc2
+! TOP 1 0
+! +OK
+! Return-Path: <from.first@mail.com>
+! Delivered-To: username@host.com
+! Received: from User.local ([66.249.71.201])
+! by mail.isp.com with ESMTP id n95BgmJg012655
+! for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+! Date: Mon, 5 Oct 2009 14:42:31 +0300
+! Message-Id: <4273644000823950677-1254742951070701@User.local>
+! MIME-Version: 1.0
+! Content-Transfer-Encoding: base64
+! From: from.first@mail.com
+! To: username@host.com
+! Subject: First test with mock POP3 server
+! Content-Type: text/plain; charset=UTF-8
+!
+! .
+! DELE 1
+! +OK Marked for deletion
+! QUIT
+! +OK POP3 server closing connection
+! Connection closed by foreign host.
+
+: process ( -- )
+ read-crlf {
+ {
+ [ dup "USER" head? ]
+ [
+
+ "+OK Password required\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "PASS" head? ]
+ [
+ "+OK Logged in\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "CAPA" = ]
+ [
+ "+OK\r\nCAPA\r\nTOP\r\nUIDL\r\n.\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "STAT" = ]
+ [
+ "+OK 2 1753\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "LIST" = ]
+ [
+ "+OK 2 messages:\r\n1 1006\r\n2 747\r\n.\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "UIDL" head? ]
+ [
+ {
+ {
+ [ dup "UIDL 1" = ]
+ [
+ "+OK 1 000000d547ac2fc2\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "UIDL 2" = ]
+ [
+ "+OK 2 000000d647ac2fc2\r\n"
+ write flush t
+ ]
+ }
+ [
+ "+OK\r\n1 000000d547ac2fc2\r\n2 000000d647ac2fc2\r\n.\r\n"
+ write flush t
+ ]
+ } cond
+ ]
+ }
+ {
+ [ dup "TOP" head? ]
+ [
+ {
+ {
+ [ dup "TOP 1 0" = ]
+ [
+"""+OK
+Return-Path: <from.first@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+Date: Mon, 5 Oct 2009 14:42:31 +0300
+Message-Id: <4273644000823950677-1254742951070701@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.first@mail.com
+To: username@host.com
+Subject: First test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+.
+"""
+ write flush t
+ ]
+ }
+ {
+ [ dup "TOP 2 0" = ]
+ [
+"""+OK
+Return-Path: <from.second@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:44:09 +0300
+Date: Mon, 5 Oct 2009 14:43:11 +0300
+Message-Id: <9783644000823934577-4563442951070856@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.second@mail.com
+To: username@host.com
+Subject: Second test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+.
+"""
+ write flush t
+ ]
+ }
+ } cond
+ ]
+ }
+ {
+ [ dup "RETR" head? ]
+ [
+ {
+ {
+ [ dup "RETR 1" = ]
+ [
+"""+OK
+Return-Path: <from.first@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+Date: Mon, 5 Oct 2009 14:42:31 +0300
+Message-Id: <4273644000823950677-1254742951070701@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.first@mail.com
+To: username@host.com
+Subject: First test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+This is the body of the first test.
+.
+"""
+ write flush t
+ ]
+ }
+ {
+ [ dup "RETR 2" = ]
+ [
+"""+OK
+Return-Path: <from.second@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:44:09 +0300
+Date: Mon, 5 Oct 2009 14:43:11 +0300
+Message-Id: <9783644000823934577-4563442951070856@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.second@mail.com
+To: username@host.com
+Subject: Second test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+This is the body of the second test.
+.
+"""
+ write flush t
+ ]
+ }
+ } cond
+ ]
+ }
+ {
+ [ dup "DELE" head? ]
+ [
+ "+OK Marked for deletion\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "RSET" = ]
+ [
+ "+OK\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "QUIT" = ]
+ [
+ "+OK POP3 server closing connection\r\n"
+ write flush f
+ ]
+ }
+ } cond nip [ process ] when ;
+
+:: mock-pop3-server ( promise -- )
+ #! Store the port we are running on in the promise.
+ [
+ [
+ "127.0.0.1" 0 <inet4> utf8 <server> [
+ dup addr>> port>> promise fulfill
+ accept drop [
+ 1 minutes timeouts
+ "+OK POP3 server ready\r\n" write flush
+ process
+ global [ flush ] bind
+ ] with-stream
+ ] with-disposal
+ ] with-test-context
+ ] in-thread ;
+
+: start-pop3-server ( -- )
+ <promise> [ mock-pop3-server ] keep ?promise
+ number>string "POP3 server started on port "
+ prepend print ;
--- /dev/null
+POP3 server for testing purposes
--- /dev/null
+Retrieve mail via POP3
--- /dev/null
+enterprise
+network
--- /dev/null
+USING: project-euler.081 tools.test ;
+IN: project-euler.081.tests
+
+[ 427337 ] [ euler081 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry io.encodings.ascii io.files locals kernel math
+math.order math.parser math.ranges sequences splitting
+project-euler.common ;
+IN: project-euler.081
+
+! http://projecteuler.net/index.php?section=problems&id=081
+
+! DESCRIPTION
+! -----------
+
+! In the 5 by 5 matrix below, the minimal path sum from the top
+! left to the bottom right, by only moving to the right and
+! down, is indicated in bold red and is equal to 2427.
+
+! 131 673 234 103 18
+! 201 96 342 965 150
+! 630 803 746 422 111
+! 537 699 497 121 956
+! 805 732 524 37 331
+
+! Find the minimal path sum, in matrix.txt (right click and
+! 'Save Link/Target As...'), a 31K text file containing a 80 by
+! 80 matrix, from the top left to the bottom right by only
+! moving right and down.
+
+
+! SOLUTION
+! --------
+
+! Shortest path problem solved using Dijkstra algorithm.
+
+<PRIVATE
+
+: source-081 ( -- matrix )
+ "resource:extra/project-euler/081/matrix.txt"
+ ascii file-lines [ "," split [ string>number ] map ] map ;
+
+: get-matrix ( x y matrix -- n ) nth nth ;
+
+: change-matrix ( x y matrix quot -- )
+ [ nth ] dip change-nth ; inline
+
+:: minimal-path-sum-to ( x y matrix -- n )
+ x y + zero? [ 0 ] [
+ x zero? [ 0 y 1 - matrix get-matrix
+ ] [
+ y zero? [
+ x 1 - 0 matrix get-matrix
+ ] [
+ x 1 - y matrix get-matrix
+ x y 1 - matrix get-matrix
+ min
+ ] if
+ ] if
+ ] if ;
+
+: update-minimal-path-sum ( x y matrix -- )
+ 3dup minimal-path-sum-to '[ _ + ] change-matrix ;
+
+: (euler081) ( matrix -- n )
+ dup first length [0,b) dup cartesian-product
+ [ first2 pick update-minimal-path-sum ] each
+ last last ;
+
+PRIVATE>
+
+: euler081 ( -- answer )
+ source-081 (euler081) ;
+
+! [ euler081 ] 100 ave-time
+! 9 ms ave run time - 0.39 SD (100 trials)
+
+SOLUTION: euler081
--- /dev/null
+Guillaume Nargeot
--- /dev/null
+4445,2697,5115,718,2209,2212,654,4348,3079,6821,7668,3276,8874,4190,3785,2752,9473,7817,9137,496,7338,3434,7152,4355,4552,7917,7827,2460,2350,691,3514,5880,3145,7633,7199,3783,5066,7487,3285,1084,8985,760,872,8609,8051,1134,9536,5750,9716,9371,7619,5617,275,9721,2997,2698,1887,8825,6372,3014,2113,7122,7050,6775,5948,2758,1219,3539,348,7989,2735,9862,1263,8089,6401,9462,3168,2758,3748,5870\r
+1096,20,1318,7586,5167,2642,1443,5741,7621,7030,5526,4244,2348,4641,9827,2448,6918,5883,3737,300,7116,6531,567,5997,3971,6623,820,6148,3287,1874,7981,8424,7672,7575,6797,6717,1078,5008,4051,8795,5820,346,1851,6463,2117,6058,3407,8211,117,4822,1317,4377,4434,5925,8341,4800,1175,4173,690,8978,7470,1295,3799,8724,3509,9849,618,3320,7068,9633,2384,7175,544,6583,1908,9983,481,4187,9353,9377\r
+9607,7385,521,6084,1364,8983,7623,1585,6935,8551,2574,8267,4781,3834,2764,2084,2669,4656,9343,7709,2203,9328,8004,6192,5856,3555,2260,5118,6504,1839,9227,1259,9451,1388,7909,5733,6968,8519,9973,1663,5315,7571,3035,4325,4283,2304,6438,3815,9213,9806,9536,196,5542,6907,2475,1159,5820,9075,9470,2179,9248,1828,4592,9167,3713,4640,47,3637,309,7344,6955,346,378,9044,8635,7466,5036,9515,6385,9230\r
+7206,3114,7760,1094,6150,5182,7358,7387,4497,955,101,1478,7777,6966,7010,8417,6453,4955,3496,107,449,8271,131,2948,6185,784,5937,8001,6104,8282,4165,3642,710,2390,575,715,3089,6964,4217,192,5949,7006,715,3328,1152,66,8044,4319,1735,146,4818,5456,6451,4113,1063,4781,6799,602,1504,6245,6550,1417,1343,2363,3785,5448,4545,9371,5420,5068,4613,4882,4241,5043,7873,8042,8434,3939,9256,2187\r
+3620,8024,577,9997,7377,7682,1314,1158,6282,6310,1896,2509,5436,1732,9480,706,496,101,6232,7375,2207,2306,110,6772,3433,2878,8140,5933,8688,1399,2210,7332,6172,6403,7333,4044,2291,1790,2446,7390,8698,5723,3678,7104,1825,2040,140,3982,4905,4160,2200,5041,2512,1488,2268,1175,7588,8321,8078,7312,977,5257,8465,5068,3453,3096,1651,7906,253,9250,6021,8791,8109,6651,3412,345,4778,5152,4883,7505\r
+1074,5438,9008,2679,5397,5429,2652,3403,770,9188,4248,2493,4361,8327,9587,707,9525,5913,93,1899,328,2876,3604,673,8576,6908,7659,2544,3359,3883,5273,6587,3065,1749,3223,604,9925,6941,2823,8767,7039,3290,3214,1787,7904,3421,7137,9560,8451,2669,9219,6332,1576,5477,6755,8348,4164,4307,2984,4012,6629,1044,2874,6541,4942,903,1404,9125,5160,8836,4345,2581,460,8438,1538,5507,668,3352,2678,6942\r
+4295,1176,5596,1521,3061,9868,7037,7129,8933,6659,5947,5063,3653,9447,9245,2679,767,714,116,8558,163,3927,8779,158,5093,2447,5782,3967,1716,931,7772,8164,1117,9244,5783,7776,3846,8862,6014,2330,6947,1777,3112,6008,3491,1906,5952,314,4602,8994,5919,9214,3995,5026,7688,6809,5003,3128,2509,7477,110,8971,3982,8539,2980,4689,6343,5411,2992,5270,5247,9260,2269,7474,1042,7162,5206,1232,4556,4757\r
+510,3556,5377,1406,5721,4946,2635,7847,4251,8293,8281,6351,4912,287,2870,3380,3948,5322,3840,4738,9563,1906,6298,3234,8959,1562,6297,8835,7861,239,6618,1322,2553,2213,5053,5446,4402,6500,5182,8585,6900,5756,9661,903,5186,7687,5998,7997,8081,8955,4835,6069,2621,1581,732,9564,1082,1853,5442,1342,520,1737,3703,5321,4793,2776,1508,1647,9101,2499,6891,4336,7012,3329,3212,1442,9993,3988,4930,7706\r
+9444,3401,5891,9716,1228,7107,109,3563,2700,6161,5039,4992,2242,8541,7372,2067,1294,3058,1306,320,8881,5756,9326,411,8650,8824,5495,8282,8397,2000,1228,7817,2099,6473,3571,5994,4447,1299,5991,543,7874,2297,1651,101,2093,3463,9189,6872,6118,872,1008,1779,2805,9084,4048,2123,5877,55,3075,1737,9459,4535,6453,3644,108,5982,4437,5213,1340,6967,9943,5815,669,8074,1838,6979,9132,9315,715,5048\r
+3327,4030,7177,6336,9933,5296,2621,4785,2755,4832,2512,2118,2244,4407,2170,499,7532,9742,5051,7687,970,6924,3527,4694,5145,1306,2165,5940,2425,8910,3513,1909,6983,346,6377,4304,9330,7203,6605,3709,3346,970,369,9737,5811,4427,9939,3693,8436,5566,1977,3728,2399,3985,8303,2492,5366,9802,9193,7296,1033,5060,9144,2766,1151,7629,5169,5995,58,7619,7565,4208,1713,6279,3209,4908,9224,7409,1325,8540\r
+6882,1265,1775,3648,4690,959,5837,4520,5394,1378,9485,1360,4018,578,9174,2932,9890,3696,116,1723,1178,9355,7063,1594,1918,8574,7594,7942,1547,6166,7888,354,6932,4651,1010,7759,6905,661,7689,6092,9292,3845,9605,8443,443,8275,5163,7720,7265,6356,7779,1798,1754,5225,6661,1180,8024,5666,88,9153,1840,3508,1193,4445,2648,3538,6243,6375,8107,5902,5423,2520,1122,5015,6113,8859,9370,966,8673,2442\r
+7338,3423,4723,6533,848,8041,7921,8277,4094,5368,7252,8852,9166,2250,2801,6125,8093,5738,4038,9808,7359,9494,601,9116,4946,2702,5573,2921,9862,1462,1269,2410,4171,2709,7508,6241,7522,615,2407,8200,4189,5492,5649,7353,2590,5203,4274,710,7329,9063,956,8371,3722,4253,4785,1194,4828,4717,4548,940,983,2575,4511,2938,1827,2027,2700,1236,841,5760,1680,6260,2373,3851,1841,4968,1172,5179,7175,3509\r
+4420,1327,3560,2376,6260,2988,9537,4064,4829,8872,9598,3228,1792,7118,9962,9336,4368,9189,6857,1829,9863,6287,7303,7769,2707,8257,2391,2009,3975,4993,3068,9835,3427,341,8412,2134,4034,8511,6421,3041,9012,2983,7289,100,1355,7904,9186,6920,5856,2008,6545,8331,3655,5011,839,8041,9255,6524,3862,8788,62,7455,3513,5003,8413,3918,2076,7960,6108,3638,6999,3436,1441,4858,4181,1866,8731,7745,3744,1000\r
+356,8296,8325,1058,1277,4743,3850,2388,6079,6462,2815,5620,8495,5378,75,4324,3441,9870,1113,165,1544,1179,2834,562,6176,2313,6836,8839,2986,9454,5199,6888,1927,5866,8760,320,1792,8296,7898,6121,7241,5886,5814,2815,8336,1576,4314,3109,2572,6011,2086,9061,9403,3947,5487,9731,7281,3159,1819,1334,3181,5844,5114,9898,4634,2531,4412,6430,4262,8482,4546,4555,6804,2607,9421,686,8649,8860,7794,6672\r
+9870,152,1558,4963,8750,4754,6521,6256,8818,5208,5691,9659,8377,9725,5050,5343,2539,6101,1844,9700,7750,8114,5357,3001,8830,4438,199,9545,8496,43,2078,327,9397,106,6090,8181,8646,6414,7499,5450,4850,6273,5014,4131,7639,3913,6571,8534,9703,4391,7618,445,1320,5,1894,6771,7383,9191,4708,9706,6939,7937,8726,9382,5216,3685,2247,9029,8154,1738,9984,2626,9438,4167,6351,5060,29,1218,1239,4785\r
+192,5213,8297,8974,4032,6966,5717,1179,6523,4679,9513,1481,3041,5355,9303,9154,1389,8702,6589,7818,6336,3539,5538,3094,6646,6702,6266,2759,4608,4452,617,9406,8064,6379,444,5602,4950,1810,8391,1536,316,8714,1178,5182,5863,5110,5372,4954,1978,2971,5680,4863,2255,4630,5723,2168,538,1692,1319,7540,440,6430,6266,7712,7385,5702,620,641,3136,7350,1478,3155,2820,9109,6261,1122,4470,14,8493,2095\r
+1046,4301,6082,474,4974,7822,2102,5161,5172,6946,8074,9716,6586,9962,9749,5015,2217,995,5388,4402,7652,6399,6539,1349,8101,3677,1328,9612,7922,2879,231,5887,2655,508,4357,4964,3554,5930,6236,7384,4614,280,3093,9600,2110,7863,2631,6626,6620,68,1311,7198,7561,1768,5139,1431,221,230,2940,968,5283,6517,2146,1646,869,9402,7068,8645,7058,1765,9690,4152,2926,9504,2939,7504,6074,2944,6470,7859\r
+4659,736,4951,9344,1927,6271,8837,8711,3241,6579,7660,5499,5616,3743,5801,4682,9748,8796,779,1833,4549,8138,4026,775,4170,2432,4174,3741,7540,8017,2833,4027,396,811,2871,1150,9809,2719,9199,8504,1224,540,2051,3519,7982,7367,2761,308,3358,6505,2050,4836,5090,7864,805,2566,2409,6876,3361,8622,5572,5895,3280,441,7893,8105,1634,2929,274,3926,7786,6123,8233,9921,2674,5340,1445,203,4585,3837\r
+5759,338,7444,7968,7742,3755,1591,4839,1705,650,7061,2461,9230,9391,9373,2413,1213,431,7801,4994,2380,2703,6161,6878,8331,2538,6093,1275,5065,5062,2839,582,1014,8109,3525,1544,1569,8622,7944,2905,6120,1564,1839,5570,7579,1318,2677,5257,4418,5601,7935,7656,5192,1864,5886,6083,5580,6202,8869,1636,7907,4759,9082,5854,3185,7631,6854,5872,5632,5280,1431,2077,9717,7431,4256,8261,9680,4487,4752,4286\r
+1571,1428,8599,1230,7772,4221,8523,9049,4042,8726,7567,6736,9033,2104,4879,4967,6334,6716,3994,1269,8995,6539,3610,7667,6560,6065,874,848,4597,1711,7161,4811,6734,5723,6356,6026,9183,2586,5636,1092,7779,7923,8747,6887,7505,9909,1792,3233,4526,3176,1508,8043,720,5212,6046,4988,709,5277,8256,3642,1391,5803,1468,2145,3970,6301,7767,2359,8487,9771,8785,7520,856,1605,8972,2402,2386,991,1383,5963\r
+1822,4824,5957,6511,9868,4113,301,9353,6228,2881,2966,6956,9124,9574,9233,1601,7340,973,9396,540,4747,8590,9535,3650,7333,7583,4806,3593,2738,8157,5215,8472,2284,9473,3906,6982,5505,6053,7936,6074,7179,6688,1564,1103,6860,5839,2022,8490,910,7551,7805,881,7024,1855,9448,4790,1274,3672,2810,774,7623,4223,4850,6071,9975,4935,1915,9771,6690,3846,517,463,7624,4511,614,6394,3661,7409,1395,8127\r
+8738,3850,9555,3695,4383,2378,87,6256,6740,7682,9546,4255,6105,2000,1851,4073,8957,9022,6547,5189,2487,303,9602,7833,1628,4163,6678,3144,8589,7096,8913,5823,4890,7679,1212,9294,5884,2972,3012,3359,7794,7428,1579,4350,7246,4301,7779,7790,3294,9547,4367,3549,1958,8237,6758,3497,3250,3456,6318,1663,708,7714,6143,6890,3428,6853,9334,7992,591,6449,9786,1412,8500,722,5468,1371,108,3939,4199,2535\r
+7047,4323,1934,5163,4166,461,3544,2767,6554,203,6098,2265,9078,2075,4644,6641,8412,9183,487,101,7566,5622,1975,5726,2920,5374,7779,5631,3753,3725,2672,3621,4280,1162,5812,345,8173,9785,1525,955,5603,2215,2580,5261,2765,2990,5979,389,3907,2484,1232,5933,5871,3304,1138,1616,5114,9199,5072,7442,7245,6472,4760,6359,9053,7876,2564,9404,3043,9026,2261,3374,4460,7306,2326,966,828,3274,1712,3446\r
+3975,4565,8131,5800,4570,2306,8838,4392,9147,11,3911,7118,9645,4994,2028,6062,5431,2279,8752,2658,7836,994,7316,5336,7185,3289,1898,9689,2331,5737,3403,1124,2679,3241,7748,16,2724,5441,6640,9368,9081,5618,858,4969,17,2103,6035,8043,7475,2181,939,415,1617,8500,8253,2155,7843,7974,7859,1746,6336,3193,2617,8736,4079,6324,6645,8891,9396,5522,6103,1857,8979,3835,2475,1310,7422,610,8345,7615\r
+9248,5397,5686,2988,3446,4359,6634,9141,497,9176,6773,7448,1907,8454,916,1596,2241,1626,1384,2741,3649,5362,8791,7170,2903,2475,5325,6451,924,3328,522,90,4813,9737,9557,691,2388,1383,4021,1609,9206,4707,5200,7107,8104,4333,9860,5013,1224,6959,8527,1877,4545,7772,6268,621,4915,9349,5970,706,9583,3071,4127,780,8231,3017,9114,3836,7503,2383,1977,4870,8035,2379,9704,1037,3992,3642,1016,4303\r
+5093,138,4639,6609,1146,5565,95,7521,9077,2272,974,4388,2465,2650,722,4998,3567,3047,921,2736,7855,173,2065,4238,1048,5,6847,9548,8632,9194,5942,4777,7910,8971,6279,7253,2516,1555,1833,3184,9453,9053,6897,7808,8629,4877,1871,8055,4881,7639,1537,7701,2508,7564,5845,5023,2304,5396,3193,2955,1088,3801,6203,1748,3737,1276,13,4120,7715,8552,3047,2921,106,7508,304,1280,7140,2567,9135,5266\r
+6237,4607,7527,9047,522,7371,4883,2540,5867,6366,5301,1570,421,276,3361,527,6637,4861,2401,7522,5808,9371,5298,2045,5096,5447,7755,5115,7060,8529,4078,1943,1697,1764,5453,7085,960,2405,739,2100,5800,728,9737,5704,5693,1431,8979,6428,673,7540,6,7773,5857,6823,150,5869,8486,684,5816,9626,7451,5579,8260,3397,5322,6920,1879,2127,2884,5478,4977,9016,6165,6292,3062,5671,5968,78,4619,4763\r
+9905,7127,9390,5185,6923,3721,9164,9705,4341,1031,1046,5127,7376,6528,3248,4941,1178,7889,3364,4486,5358,9402,9158,8600,1025,874,1839,1783,309,9030,1843,845,8398,1433,7118,70,8071,2877,3904,8866,6722,4299,10,1929,5897,4188,600,1889,3325,2485,6473,4474,7444,6992,4846,6166,4441,2283,2629,4352,7775,1101,2214,9985,215,8270,9750,2740,8361,7103,5930,8664,9690,8302,9267,344,2077,1372,1880,9550\r
+5825,8517,7769,2405,8204,1060,3603,7025,478,8334,1997,3692,7433,9101,7294,7498,9415,5452,3850,3508,6857,9213,6807,4412,7310,854,5384,686,4978,892,8651,3241,2743,3801,3813,8588,6701,4416,6990,6490,3197,6838,6503,114,8343,5844,8646,8694,65,791,5979,2687,2621,2019,8097,1423,3644,9764,4921,3266,3662,5561,2476,8271,8138,6147,1168,3340,1998,9874,6572,9873,6659,5609,2711,3931,9567,4143,7833,8887\r
+6223,2099,2700,589,4716,8333,1362,5007,2753,2848,4441,8397,7192,8191,4916,9955,6076,3370,6396,6971,3156,248,3911,2488,4930,2458,7183,5455,170,6809,6417,3390,1956,7188,577,7526,2203,968,8164,479,8699,7915,507,6393,4632,1597,7534,3604,618,3280,6061,9793,9238,8347,568,9645,2070,5198,6482,5000,9212,6655,5961,7513,1323,3872,6170,3812,4146,2736,67,3151,5548,2781,9679,7564,5043,8587,1893,4531\r
+5826,3690,6724,2121,9308,6986,8106,6659,2142,1642,7170,2877,5757,6494,8026,6571,8387,9961,6043,9758,9607,6450,8631,8334,7359,5256,8523,2225,7487,1977,9555,8048,5763,2414,4948,4265,2427,8978,8088,8841,9208,9601,5810,9398,8866,9138,4176,5875,7212,3272,6759,5678,7649,4922,5422,1343,8197,3154,3600,687,1028,4579,2084,9467,4492,7262,7296,6538,7657,7134,2077,1505,7332,6890,8964,4879,7603,7400,5973,739\r
+1861,1613,4879,1884,7334,966,2000,7489,2123,4287,1472,3263,4726,9203,1040,4103,6075,6049,330,9253,4062,4268,1635,9960,577,1320,3195,9628,1030,4092,4979,6474,6393,2799,6967,8687,7724,7392,9927,2085,3200,6466,8702,265,7646,8665,7986,7266,4574,6587,612,2724,704,3191,8323,9523,3002,704,5064,3960,8209,2027,2758,8393,4875,4641,9584,6401,7883,7014,768,443,5490,7506,1852,2005,8850,5776,4487,4269\r
+4052,6687,4705,7260,6645,6715,3706,5504,8672,2853,1136,8187,8203,4016,871,1809,1366,4952,9294,5339,6872,2645,6083,7874,3056,5218,7485,8796,7401,3348,2103,426,8572,4163,9171,3176,948,7654,9344,3217,1650,5580,7971,2622,76,2874,880,2034,9929,1546,2659,5811,3754,7096,7436,9694,9960,7415,2164,953,2360,4194,2397,1047,2196,6827,575,784,2675,8821,6802,7972,5996,6699,2134,7577,2887,1412,4349,4380\r
+4629,2234,6240,8132,7592,3181,6389,1214,266,1910,2451,8784,2790,1127,6932,1447,8986,2492,5476,397,889,3027,7641,5083,5776,4022,185,3364,5701,2442,2840,4160,9525,4828,6602,2614,7447,3711,4505,7745,8034,6514,4907,2605,7753,6958,7270,6936,3006,8968,439,2326,4652,3085,3425,9863,5049,5361,8688,297,7580,8777,7916,6687,8683,7141,306,9569,2384,1500,3346,4601,7329,9040,6097,2727,6314,4501,4974,2829\r
+8316,4072,2025,6884,3027,1808,5714,7624,7880,8528,4205,8686,7587,3230,1139,7273,6163,6986,3914,9309,1464,9359,4474,7095,2212,7302,2583,9462,7532,6567,1606,4436,8981,5612,6796,4385,5076,2007,6072,3678,8331,1338,3299,8845,4783,8613,4071,1232,6028,2176,3990,2148,3748,103,9453,538,6745,9110,926,3125,473,5970,8728,7072,9062,1404,1317,5139,9862,6496,6062,3338,464,1600,2532,1088,8232,7739,8274,3873\r
+2341,523,7096,8397,8301,6541,9844,244,4993,2280,7689,4025,4196,5522,7904,6048,2623,9258,2149,9461,6448,8087,7245,1917,8340,7127,8466,5725,6996,3421,5313,512,9164,9837,9794,8369,4185,1488,7210,1524,1016,4620,9435,2478,7765,8035,697,6677,3724,6988,5853,7662,3895,9593,1185,4727,6025,5734,7665,3070,138,8469,6748,6459,561,7935,8646,2378,462,7755,3115,9690,8877,3946,2728,8793,244,6323,8666,4271\r
+6430,2406,8994,56,1267,3826,9443,7079,7579,5232,6691,3435,6718,5698,4144,7028,592,2627,217,734,6194,8156,9118,58,2640,8069,4127,3285,694,3197,3377,4143,4802,3324,8134,6953,7625,3598,3584,4289,7065,3434,2106,7132,5802,7920,9060,7531,3321,1725,1067,3751,444,5503,6785,7937,6365,4803,198,6266,8177,1470,6390,1606,2904,7555,9834,8667,2033,1723,5167,1666,8546,8152,473,4475,6451,7947,3062,3281\r
+2810,3042,7759,1741,2275,2609,7676,8640,4117,1958,7500,8048,1757,3954,9270,1971,4796,2912,660,5511,3553,1012,5757,4525,6084,7198,8352,5775,7726,8591,7710,9589,3122,4392,6856,5016,749,2285,3356,7482,9956,7348,2599,8944,495,3462,3578,551,4543,7207,7169,7796,1247,4278,6916,8176,3742,8385,2310,1345,8692,2667,4568,1770,8319,3585,4920,3890,4928,7343,5385,9772,7947,8786,2056,9266,3454,2807,877,2660\r
+6206,8252,5928,5837,4177,4333,207,7934,5581,9526,8906,1498,8411,2984,5198,5134,2464,8435,8514,8674,3876,599,5327,826,2152,4084,2433,9327,9697,4800,2728,3608,3849,3861,3498,9943,1407,3991,7191,9110,5666,8434,4704,6545,5944,2357,1163,4995,9619,6754,4200,9682,6654,4862,4744,5953,6632,1054,293,9439,8286,2255,696,8709,1533,1844,6441,430,1999,6063,9431,7018,8057,2920,6266,6799,356,3597,4024,6665\r
+3847,6356,8541,7225,2325,2946,5199,469,5450,7508,2197,9915,8284,7983,6341,3276,3321,16,1321,7608,5015,3362,8491,6968,6818,797,156,2575,706,9516,5344,5457,9210,5051,8099,1617,9951,7663,8253,9683,2670,1261,4710,1068,8753,4799,1228,2621,3275,6188,4699,1791,9518,8701,5932,4275,6011,9877,2933,4182,6059,2930,6687,6682,9771,654,9437,3169,8596,1827,5471,8909,2352,123,4394,3208,8756,5513,6917,2056\r
+5458,8173,3138,3290,4570,4892,3317,4251,9699,7973,1163,1935,5477,6648,9614,5655,9592,975,9118,2194,7322,8248,8413,3462,8560,1907,7810,6650,7355,2939,4973,6894,3933,3784,3200,2419,9234,4747,2208,2207,1945,2899,1407,6145,8023,3484,5688,7686,2737,3828,3704,9004,5190,9740,8643,8650,5358,4426,1522,1707,3613,9887,6956,2447,2762,833,1449,9489,2573,1080,4167,3456,6809,2466,227,7125,2759,6250,6472,8089\r
+3266,7025,9756,3914,1265,9116,7723,9788,6805,5493,2092,8688,6592,9173,4431,4028,6007,7131,4446,4815,3648,6701,759,3312,8355,4485,4187,5188,8746,7759,3528,2177,5243,8379,3838,7233,4607,9187,7216,2190,6967,2920,6082,7910,5354,3609,8958,6949,7731,494,8753,8707,1523,4426,3543,7085,647,6771,9847,646,5049,824,8417,5260,2730,5702,2513,9275,4279,2767,8684,1165,9903,4518,55,9682,8963,6005,2102,6523\r
+1998,8731,936,1479,5259,7064,4085,91,7745,7136,3773,3810,730,8255,2705,2653,9790,6807,2342,355,9344,2668,3690,2028,9679,8102,574,4318,6481,9175,5423,8062,2867,9657,7553,3442,3920,7430,3945,7639,3714,3392,2525,4995,4850,2867,7951,9667,486,9506,9888,781,8866,1702,3795,90,356,1483,4200,2131,6969,5931,486,6880,4404,1084,5169,4910,6567,8335,4686,5043,2614,3352,2667,4513,6472,7471,5720,1616\r
+8878,1613,1716,868,1906,2681,564,665,5995,2474,7496,3432,9491,9087,8850,8287,669,823,347,6194,2264,2592,7871,7616,8508,4827,760,2676,4660,4881,7572,3811,9032,939,4384,929,7525,8419,5556,9063,662,8887,7026,8534,3111,1454,2082,7598,5726,6687,9647,7608,73,3014,5063,670,5461,5631,3367,9796,8475,7908,5073,1565,5008,5295,4457,1274,4788,1728,338,600,8415,8535,9351,7750,6887,5845,1741,125\r
+3637,6489,9634,9464,9055,2413,7824,9517,7532,3577,7050,6186,6980,9365,9782,191,870,2497,8498,2218,2757,5420,6468,586,3320,9230,1034,1393,9886,5072,9391,1178,8464,8042,6869,2075,8275,3601,7715,9470,8786,6475,8373,2159,9237,2066,3264,5000,679,355,3069,4073,494,2308,5512,4334,9438,8786,8637,9774,1169,1949,6594,6072,4270,9158,7916,5752,6794,9391,6301,5842,3285,2141,3898,8027,4310,8821,7079,1307\r
+8497,6681,4732,7151,7060,5204,9030,7157,833,5014,8723,3207,9796,9286,4913,119,5118,7650,9335,809,3675,2597,5144,3945,5090,8384,187,4102,1260,2445,2792,4422,8389,9290,50,1765,1521,6921,8586,4368,1565,5727,7855,2003,4834,9897,5911,8630,5070,1330,7692,7557,7980,6028,5805,9090,8265,3019,3802,698,9149,5748,1965,9658,4417,5994,5584,8226,2937,272,5743,1278,5698,8736,2595,6475,5342,6596,1149,6920\r
+8188,8009,9546,6310,8772,2500,9846,6592,6872,3857,1307,8125,7042,1544,6159,2330,643,4604,7899,6848,371,8067,2062,3200,7295,1857,9505,6936,384,2193,2190,301,8535,5503,1462,7380,5114,4824,8833,1763,4974,8711,9262,6698,3999,2645,6937,7747,1128,2933,3556,7943,2885,3122,9105,5447,418,2899,5148,3699,9021,9501,597,4084,175,1621,1,1079,6067,5812,4326,9914,6633,5394,4233,6728,9084,1864,5863,1225\r
+9935,8793,9117,1825,9542,8246,8437,3331,9128,9675,6086,7075,319,1334,7932,3583,7167,4178,1726,7720,695,8277,7887,6359,5912,1719,2780,8529,1359,2013,4498,8072,1129,9998,1147,8804,9405,6255,1619,2165,7491,1,8882,7378,3337,503,5758,4109,3577,985,3200,7615,8058,5032,1080,6410,6873,5496,1466,2412,9885,5904,4406,3605,8770,4361,6205,9193,1537,9959,214,7260,9566,1685,100,4920,7138,9819,5637,976\r
+3466,9854,985,1078,7222,8888,5466,5379,3578,4540,6853,8690,3728,6351,7147,3134,6921,9692,857,3307,4998,2172,5783,3931,9417,2541,6299,13,787,2099,9131,9494,896,8600,1643,8419,7248,2660,2609,8579,91,6663,5506,7675,1947,6165,4286,1972,9645,3805,1663,1456,8853,5705,9889,7489,1107,383,4044,2969,3343,152,7805,4980,9929,5033,1737,9953,7197,9158,4071,1324,473,9676,3984,9680,3606,8160,7384,5432\r
+1005,4512,5186,3953,2164,3372,4097,3247,8697,3022,9896,4101,3871,6791,3219,2742,4630,6967,7829,5991,6134,1197,1414,8923,8787,1394,8852,5019,7768,5147,8004,8825,5062,9625,7988,1110,3992,7984,9966,6516,6251,8270,421,3723,1432,4830,6935,8095,9059,2214,6483,6846,3120,1587,6201,6691,9096,9627,6671,4002,3495,9939,7708,7465,5879,6959,6634,3241,3401,2355,9061,2611,7830,3941,2177,2146,5089,7079,519,6351\r
+7280,8586,4261,2831,7217,3141,9994,9940,5462,2189,4005,6942,9848,5350,8060,6665,7519,4324,7684,657,9453,9296,2944,6843,7499,7847,1728,9681,3906,6353,5529,2822,3355,3897,7724,4257,7489,8672,4356,3983,1948,6892,7415,4153,5893,4190,621,1736,4045,9532,7701,3671,1211,1622,3176,4524,9317,7800,5638,6644,6943,5463,3531,2821,1347,5958,3436,1438,2999,994,850,4131,2616,1549,3465,5946,690,9273,6954,7991\r
+9517,399,3249,2596,7736,2142,1322,968,7350,1614,468,3346,3265,7222,6086,1661,5317,2582,7959,4685,2807,2917,1037,5698,1529,3972,8716,2634,3301,3412,8621,743,8001,4734,888,7744,8092,3671,8941,1487,5658,7099,2781,99,1932,4443,4756,4652,9328,1581,7855,4312,5976,7255,6480,3996,2748,1973,9731,4530,2790,9417,7186,5303,3557,351,7182,9428,1342,9020,7599,1392,8304,2070,9138,7215,2008,9937,1106,7110\r
+7444,769,9688,632,1571,6820,8743,4338,337,3366,3073,1946,8219,104,4210,6986,249,5061,8693,7960,6546,1004,8857,5997,9352,4338,6105,5008,2556,6518,6694,4345,3727,7956,20,3954,8652,4424,9387,2035,8358,5962,5304,5194,8650,8282,1256,1103,2138,6679,1985,3653,2770,2433,4278,615,2863,1715,242,3790,2636,6998,3088,1671,2239,957,5411,4595,6282,2881,9974,2401,875,7574,2987,4587,3147,6766,9885,2965\r
+3287,3016,3619,6818,9073,6120,5423,557,2900,2015,8111,3873,1314,4189,1846,4399,7041,7583,2427,2864,3525,5002,2069,748,1948,6015,2684,438,770,8367,1663,7887,7759,1885,157,7770,4520,4878,3857,1137,3525,3050,6276,5569,7649,904,4533,7843,2199,5648,7628,9075,9441,3600,7231,2388,5640,9096,958,3058,584,5899,8150,1181,9616,1098,8162,6819,8171,1519,1140,7665,8801,2632,1299,9192,707,9955,2710,7314\r
+1772,2963,7578,3541,3095,1488,7026,2634,6015,4633,4370,2762,1650,2174,909,8158,2922,8467,4198,4280,9092,8856,8835,5457,2790,8574,9742,5054,9547,4156,7940,8126,9824,7340,8840,6574,3547,1477,3014,6798,7134,435,9484,9859,3031,4,1502,4133,1738,1807,4825,463,6343,9701,8506,9822,9555,8688,8168,3467,3234,6318,1787,5591,419,6593,7974,8486,9861,6381,6758,194,3061,4315,2863,4665,3789,2201,1492,4416\r
+126,8927,6608,5682,8986,6867,1715,6076,3159,788,3140,4744,830,9253,5812,5021,7616,8534,1546,9590,1101,9012,9821,8132,7857,4086,1069,7491,2988,1579,2442,4321,2149,7642,6108,250,6086,3167,24,9528,7663,2685,1220,9196,1397,5776,1577,1730,5481,977,6115,199,6326,2183,3767,5928,5586,7561,663,8649,9688,949,5913,9160,1870,5764,9887,4477,6703,1413,4995,5494,7131,2192,8969,7138,3997,8697,646,1028\r
+8074,1731,8245,624,4601,8706,155,8891,309,2552,8208,8452,2954,3124,3469,4246,3352,1105,4509,8677,9901,4416,8191,9283,5625,7120,2952,8881,7693,830,4580,8228,9459,8611,4499,1179,4988,1394,550,2336,6089,6872,269,7213,1848,917,6672,4890,656,1478,6536,3165,4743,4990,1176,6211,7207,5284,9730,4738,1549,4986,4942,8645,3698,9429,1439,2175,6549,3058,6513,1574,6988,8333,3406,5245,5431,7140,7085,6407\r
+7845,4694,2530,8249,290,5948,5509,1588,5940,4495,5866,5021,4626,3979,3296,7589,4854,1998,5627,3926,8346,6512,9608,1918,7070,4747,4182,2858,2766,4606,6269,4107,8982,8568,9053,4244,5604,102,2756,727,5887,2566,7922,44,5986,621,1202,374,6988,4130,3627,6744,9443,4568,1398,8679,397,3928,9159,367,2917,6127,5788,3304,8129,911,2669,1463,9749,264,4478,8940,1109,7309,2462,117,4692,7724,225,2312\r
+4164,3637,2000,941,8903,39,3443,7172,1031,3687,4901,8082,4945,4515,7204,9310,9349,9535,9940,218,1788,9245,2237,1541,5670,6538,6047,5553,9807,8101,1925,8714,445,8332,7309,6830,5786,5736,7306,2710,3034,1838,7969,6318,7912,2584,2080,7437,6705,2254,7428,820,782,9861,7596,3842,3631,8063,5240,6666,394,4565,7865,4895,9890,6028,6117,4724,9156,4473,4552,602,470,6191,4927,5387,884,3146,1978,3000\r
+4258,6880,1696,3582,5793,4923,2119,1155,9056,9698,6603,3768,5514,9927,9609,6166,6566,4536,4985,4934,8076,9062,6741,6163,7399,4562,2337,5600,2919,9012,8459,1308,6072,1225,9306,8818,5886,7243,7365,8792,6007,9256,6699,7171,4230,7002,8720,7839,4533,1671,478,7774,1607,2317,5437,4705,7886,4760,6760,7271,3081,2997,3088,7675,6208,3101,6821,6840,122,9633,4900,2067,8546,4549,2091,7188,5605,8599,6758,5229\r
+7854,5243,9155,3556,8812,7047,2202,1541,5993,4600,4760,713,434,7911,7426,7414,8729,322,803,7960,7563,4908,6285,6291,736,3389,9339,4132,8701,7534,5287,3646,592,3065,7582,2592,8755,6068,8597,1982,5782,1894,2900,6236,4039,6569,3037,5837,7698,700,7815,2491,7272,5878,3083,6778,6639,3589,5010,8313,2581,6617,5869,8402,6808,2951,2321,5195,497,2190,6187,1342,1316,4453,7740,4154,2959,1781,1482,8256\r
+7178,2046,4419,744,8312,5356,6855,8839,319,2962,5662,47,6307,8662,68,4813,567,2712,9931,1678,3101,8227,6533,4933,6656,92,5846,4780,6256,6361,4323,9985,1231,2175,7178,3034,9744,6155,9165,7787,5836,9318,7860,9644,8941,6480,9443,8188,5928,161,6979,2352,5628,6991,1198,8067,5867,6620,3778,8426,2994,3122,3124,6335,3918,8897,2655,9670,634,1088,1576,8935,7255,474,8166,7417,9547,2886,5560,3842\r
+6957,3111,26,7530,7143,1295,1744,6057,3009,1854,8098,5405,2234,4874,9447,2620,9303,27,7410,969,40,2966,5648,7596,8637,4238,3143,3679,7187,690,9980,7085,7714,9373,5632,7526,6707,3951,9734,4216,2146,3602,5371,6029,3039,4433,4855,4151,1449,3376,8009,7240,7027,4602,2947,9081,4045,8424,9352,8742,923,2705,4266,3232,2264,6761,363,2651,3383,7770,6730,7856,7340,9679,2158,610,4471,4608,910,6241\r
+4417,6756,1013,8797,658,8809,5032,8703,7541,846,3357,2920,9817,1745,9980,7593,4667,3087,779,3218,6233,5568,4296,2289,2654,7898,5021,9461,5593,8214,9173,4203,2271,7980,2983,5952,9992,8399,3468,1776,3188,9314,1720,6523,2933,621,8685,5483,8986,6163,3444,9539,4320,155,3992,2828,2150,6071,524,2895,5468,8063,1210,3348,9071,4862,483,9017,4097,6186,9815,3610,5048,1644,1003,9865,9332,2145,1944,2213\r
+9284,3803,4920,1927,6706,4344,7383,4786,9890,2010,5228,1224,3158,6967,8580,8990,8883,5213,76,8306,2031,4980,5639,9519,7184,5645,7769,3259,8077,9130,1317,3096,9624,3818,1770,695,2454,947,6029,3474,9938,3527,5696,4760,7724,7738,2848,6442,5767,6845,8323,4131,2859,7595,2500,4815,3660,9130,8580,7016,8231,4391,8369,3444,4069,4021,556,6154,627,2778,1496,4206,6356,8434,8491,3816,8231,3190,5575,1015\r
+3787,7572,1788,6803,5641,6844,1961,4811,8535,9914,9999,1450,8857,738,4662,8569,6679,2225,7839,8618,286,2648,5342,2294,3205,4546,176,8705,3741,6134,8324,8021,7004,5205,7032,6637,9442,5539,5584,4819,5874,5807,8589,6871,9016,983,1758,3786,1519,6241,185,8398,495,3370,9133,3051,4549,9674,7311,9738,3316,9383,2658,2776,9481,7558,619,3943,3324,6491,4933,153,9738,4623,912,3595,7771,7939,1219,4405\r
+2650,3883,4154,5809,315,7756,4430,1788,4451,1631,6461,7230,6017,5751,138,588,5282,2442,9110,9035,6349,2515,1570,6122,4192,4174,3530,1933,4186,4420,4609,5739,4135,2963,6308,1161,8809,8619,2796,3819,6971,8228,4188,1492,909,8048,2328,6772,8467,7671,9068,2226,7579,6422,7056,8042,3296,2272,3006,2196,7320,3238,3490,3102,37,1293,3212,4767,5041,8773,5794,4456,6174,7279,7054,2835,7053,9088,790,6640\r
+3101,1057,7057,3826,6077,1025,2955,1224,1114,6729,5902,4698,6239,7203,9423,1804,4417,6686,1426,6941,8071,1029,4985,9010,6122,6597,1622,1574,3513,1684,7086,5505,3244,411,9638,4150,907,9135,829,981,1707,5359,8781,9751,5,9131,3973,7159,1340,6955,7514,7993,6964,8198,1933,2797,877,3993,4453,8020,9349,8646,2779,8679,2961,3547,3374,3510,1129,3568,2241,2625,9138,5974,8206,7669,7678,1833,8700,4480\r
+4865,9912,8038,8238,782,3095,8199,1127,4501,7280,2112,2487,3626,2790,9432,1475,6312,8277,4827,2218,5806,7132,8752,1468,7471,6386,739,8762,8323,8120,5169,9078,9058,3370,9560,7987,8585,8531,5347,9312,1058,4271,1159,5286,5404,6925,8606,9204,7361,2415,560,586,4002,2644,1927,2824,768,4409,2942,3345,1002,808,4941,6267,7979,5140,8643,7553,9438,7320,4938,2666,4609,2778,8158,6730,3748,3867,1866,7181\r
+171,3771,7134,8927,4778,2913,3326,2004,3089,7853,1378,1729,4777,2706,9578,1360,5693,3036,1851,7248,2403,2273,8536,6501,9216,613,9671,7131,7719,6425,773,717,8803,160,1114,7554,7197,753,4513,4322,8499,4533,2609,4226,8710,6627,644,9666,6260,4870,5744,7385,6542,6203,7703,6130,8944,5589,2262,6803,6381,7414,6888,5123,7320,9392,9061,6780,322,8975,7050,5089,1061,2260,3199,1150,1865,5386,9699,6501\r
+3744,8454,6885,8277,919,1923,4001,6864,7854,5519,2491,6057,8794,9645,1776,5714,9786,9281,7538,6916,3215,395,2501,9618,4835,8846,9708,2813,3303,1794,8309,7176,2206,1602,1838,236,4593,2245,8993,4017,10,8215,6921,5206,4023,5932,6997,7801,262,7640,3107,8275,4938,7822,2425,3223,3886,2105,8700,9526,2088,8662,8034,7004,5710,2124,7164,3574,6630,9980,4242,2901,9471,1491,2117,4562,1130,9086,4117,6698\r
+2810,2280,2331,1170,4554,4071,8387,1215,2274,9848,6738,1604,7281,8805,439,1298,8318,7834,9426,8603,6092,7944,1309,8828,303,3157,4638,4439,9175,1921,4695,7716,1494,1015,1772,5913,1127,1952,1950,8905,4064,9890,385,9357,7945,5035,7082,5369,4093,6546,5187,5637,2041,8946,1758,7111,6566,1027,1049,5148,7224,7248,296,6169,375,1656,7993,2816,3717,4279,4675,1609,3317,42,6201,3100,3144,163,9530,4531\r
+7096,6070,1009,4988,3538,5801,7149,3063,2324,2912,7911,7002,4338,7880,2481,7368,3516,2016,7556,2193,1388,3865,8125,4637,4096,8114,750,3144,1938,7002,9343,4095,1392,4220,3455,6969,9647,1321,9048,1996,1640,6626,1788,314,9578,6630,2813,6626,4981,9908,7024,4355,3201,3521,3864,3303,464,1923,595,9801,3391,8366,8084,9374,1041,8807,9085,1892,9431,8317,9016,9221,8574,9981,9240,5395,2009,6310,2854,9255\r
+8830,3145,2960,9615,8220,6061,3452,2918,6481,9278,2297,3385,6565,7066,7316,5682,107,7646,4466,68,1952,9603,8615,54,7191,791,6833,2560,693,9733,4168,570,9127,9537,1925,8287,5508,4297,8452,8795,6213,7994,2420,4208,524,5915,8602,8330,2651,8547,6156,1812,6271,7991,9407,9804,1553,6866,1128,2119,4691,9711,8315,5879,9935,6900,482,682,4126,1041,428,6247,3720,5882,7526,2582,4327,7725,3503,2631\r
+2738,9323,721,7434,1453,6294,2957,3786,5722,6019,8685,4386,3066,9057,6860,499,5315,3045,5194,7111,3137,9104,941,586,3066,755,4177,8819,7040,5309,3583,3897,4428,7788,4721,7249,6559,7324,825,7311,3760,6064,6070,9672,4882,584,1365,9739,9331,5783,2624,7889,1604,1303,1555,7125,8312,425,8936,3233,7724,1480,403,7440,1784,1754,4721,1569,652,3893,4574,5692,9730,4813,9844,8291,9199,7101,3391,8914\r
+6044,2928,9332,3328,8588,447,3830,1176,3523,2705,8365,6136,5442,9049,5526,8575,8869,9031,7280,706,2794,8814,5767,4241,7696,78,6570,556,5083,1426,4502,3336,9518,2292,1885,3740,3153,9348,9331,8051,2759,5407,9028,7840,9255,831,515,2612,9747,7435,8964,4971,2048,4900,5967,8271,1719,9670,2810,6777,1594,6367,6259,8316,3815,1689,6840,9437,4361,822,9619,3065,83,6344,7486,8657,8228,9635,6932,4864\r
+8478,4777,6334,4678,7476,4963,6735,3096,5860,1405,5127,7269,7793,4738,227,9168,2996,8928,765,733,1276,7677,6258,1528,9558,3329,302,8901,1422,8277,6340,645,9125,8869,5952,141,8141,1816,9635,4025,4184,3093,83,2344,2747,9352,7966,1206,1126,1826,218,7939,2957,2729,810,8752,5247,4174,4038,8884,7899,9567,301,5265,5752,7524,4381,1669,3106,8270,6228,6373,754,2547,4240,2313,5514,3022,1040,9738\r
+2265,8192,1763,1369,8469,8789,4836,52,1212,6690,5257,8918,6723,6319,378,4039,2421,8555,8184,9577,1432,7139,8078,5452,9628,7579,4161,7490,5159,8559,1011,81,478,5840,1964,1334,6875,8670,9900,739,1514,8692,522,9316,6955,1345,8132,2277,3193,9773,3923,4177,2183,1236,6747,6575,4874,6003,6409,8187,745,8776,9440,7543,9825,2582,7381,8147,7236,5185,7564,6125,218,7991,6394,391,7659,7456,5128,5294\r
+2132,8992,8160,5782,4420,3371,3798,5054,552,5631,7546,4716,1332,6486,7892,7441,4370,6231,4579,2121,8615,1145,9391,1524,1385,2400,9437,2454,7896,7467,2928,8400,3299,4025,7458,4703,7206,6358,792,6200,725,4275,4136,7390,5984,4502,7929,5085,8176,4600,119,3568,76,9363,6943,2248,9077,9731,6213,5817,6729,4190,3092,6910,759,2682,8380,1254,9604,3011,9291,5329,9453,9746,2739,6522,3765,5634,1113,5789\r
+5304,5499,564,2801,679,2653,1783,3608,7359,7797,3284,796,3222,437,7185,6135,8571,2778,7488,5746,678,6140,861,7750,803,9859,9918,2425,3734,2698,9005,4864,9818,6743,2475,132,9486,3825,5472,919,292,4411,7213,7699,6435,9019,6769,1388,802,2124,1345,8493,9487,8558,7061,8777,8833,2427,2238,5409,4957,8503,3171,7622,5779,6145,2417,5873,5563,5693,9574,9491,1937,7384,4563,6842,5432,2751,3406,7981\r
project-euler.058 project-euler.059 project-euler.063 project-euler.065
project-euler.067 project-euler.069 project-euler.071 project-euler.072
project-euler.073 project-euler.074 project-euler.075 project-euler.076
- project-euler.079 project-euler.085 project-euler.092 project-euler.097
- project-euler.099 project-euler.100 project-euler.102 project-euler.112
- project-euler.116 project-euler.117 project-euler.124 project-euler.134
- project-euler.148 project-euler.150 project-euler.151 project-euler.164
- project-euler.169 project-euler.173 project-euler.175 project-euler.186
- project-euler.188 project-euler.190 project-euler.203 project-euler.215 ;
+ project-euler.079 project-euler.081 project-euler.085 project-euler.092
+ project-euler.097 project-euler.099 project-euler.100 project-euler.102
+ project-euler.112 project-euler.116 project-euler.117 project-euler.124
+ project-euler.134 project-euler.148 project-euler.150 project-euler.151
+ project-euler.164 project-euler.169 project-euler.173 project-euler.175
+ project-euler.186 project-euler.188 project-euler.190 project-euler.203
+ project-euler.215 ;
IN: project-euler
<PRIVATE
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel random random.cmwc sequences
-specialized-arrays specialized-arrays.instances.uint tools.test ;
+specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: uint
IN: random.cmwc.tests
[ ] [
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays fry kernel locals math
math.bitwise random sequences sequences.private
-specialized-arrays specialized-arrays.instances.uint ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: uint
IN: random.cmwc
! Multiply-with-carry RNG
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel math.functions random random.lagged-fibonacci
-sequences specialized-arrays.instances.double tools.test ;
+sequences tools.test specialized-arrays alien.c-types ;
+SPECIALIZED-ARRAY: double
IN: random.lagged-fibonacci.tests
[ t ] [
ui.gadgets
ui.gestures
ui.render
+ specialized-arrays
;
QUALIFIED: threads
QUALIFIED: system
+SPECIALIZED-ARRAY: uchar
IN: space-invaders
-<<
- "uchar" require-c-array
->>
-
TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
CONSTANT: game-width 224
CONSTANT: game-height 256
USING: accessors assocs arrays kernel models monads sequences
models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons.private ui.gadgets.editors words images.loader
-ui.gadgets.scrollers ui.images vocabs.parser lexer
+ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
+words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
models.range ui.gadgets.sliders ;
QUALIFIED-WITH: ui.gadgets.sliders slider
QUALIFIED-WITH: ui.gadgets.tables tbl
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup modules.rpc-server modules.using ;
+IN: modules.rpc-server
+HELP: service
+{ $syntax "IN: my-vocab service" }
+{ $description "Allows words defined in the vocabulary to be used as remote procedure calls by " { $link POSTPONE: USING*: } } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators continuations effects
+io.encodings.binary io.servers.connection kernel namespaces
+sequences serialize sets threads vocabs vocabs.parser init io ;
+IN: modules.rpc-server
+
+<PRIVATE
+TUPLE: rpc-request args vocabspec wordname ;
+SYMBOL: serving-vocabs serving-vocabs [ V{ } clone ] initialize
+
+: getter ( -- ) deserialize dup serving-vocabs get-global index
+ [ vocab-words [ stack-effect ] { } assoc-map-as ]
+ [ \ no-vocab boa ] if serialize flush ;
+
+: doer ( -- ) deserialize dup vocabspec>> serving-vocabs get-global index
+ [ [ args>> ] [ wordname>> ] [ vocabspec>> vocab-words ] tri at [ execute ] curry with-datastack ]
+ [ vocabspec>> \ no-vocab boa ] if serialize flush ;
+
+PRIVATE>
+SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
+
+: start-rpc-server ( -- )
+ binary <threaded-server>
+ "rpcs" >>name 9012 >>insecure
+ [ deserialize {
+ { "getter" [ getter ] }
+ { "doer" [ doer ] }
+ { "loader" [ deserialize vocab serialize flush ] }
+ } case ] >>handler
+ start-server ;
--- /dev/null
+Serve factor words as rpcs
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry generalizations io.encodings.binary
+io.sockets kernel locals namespaces parser sequences serialize
+vocabs vocabs.parser words io ;
+IN: modules.rpc
+
+TUPLE: rpc-request args vocabspec wordname ;
+
+: send-with-check ( message -- reply/* )
+ serialize flush deserialize dup no-vocab? [ throw ] when ;
+
+:: define-remote ( str effect addrspec vocabspec -- )
+ str create-in effect [ in>> length ] [ out>> length ] bi
+ '[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary
+ [ "doer" serialize send-with-check ] with-client _ firstn ]
+ effect define-declared ;
+
+:: remote-vocab ( addrspec vocabspec -- vocab )
+ vocabspec "-remote" append dup vocab [ dup set-current-vocab
+ vocabspec addrspec 9012 <inet> binary [ "getter" serialize send-with-check ] with-client
+ [ first2 addrspec vocabspec define-remote ] each
+ ] unless ;
+
+: remote-load ( addr vocabspec -- voabspec ) [ swap
+ 9012 <inet> binary [ "loader" serialize serialize flush deserialize ] with-client ] keep
+ [ dictionary get-global set-at ] keep ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+Improved module import syntax with network transparency
\ No newline at end of file
--- /dev/null
+USING: help.syntax help.markup strings modules.using ;
+IN: modules.using
+ARTICLE: { "modules.using" "use" } "Using the modules.using vocab"
+"This vocabulary defines " { $link POSTPONE: USING*: } " as an alternative to " { $link POSTPONE: USING: } " which makes qualified imports easier. "
+"Secondly, it allows loading vocabularies from remote servers, as long as the remote vocabulary can be accessed at compile time. "
+"Finally, the word can treat words in remote vocabularies as remote procedure calls. Any inputs are passed to the imported words as normal, and the result will appear on the stack- the only difference is that the word isn't called locally." ;
+ABOUT: { "modules.using" "use" }
+
+HELP: USING*:
+{ $syntax "USING: rpc-server::module fetch-sever:module { module qualified-name } { module => word ... } { qualified-module } { module EXCEPT word ... } { module word => importname } ;" }
+{ $description "Adds vocabularies to the search path. Vocabularies can be loaded off a server or called as an rpc if preceded by a valid hostname. Bracketed pairs facilitate all types of qualified imports on both remote and local modules." } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel modules.rpc peg peg-lexer peg.ebnf sequences
+strings vocabs.parser ;
+IN: modules.using
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+module = rpc | remote | tokenpart
+;EBNF
+
+ON-BNF: USING*:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>"|"EXCEPT").
+modspec = sym => [[ modulize ]]
+qualified-with = modspec sym => [[ first2 add-qualified ignore ]]
+qualified = modspec => [[ dup add-qualified ignore ]]
+from = modspec "=>" sym+ => [[ first3 nip add-words-from ignore ]]
+exclude = modspec "EXCEPT" sym+ => [[ first3 nip add-words-excluding ignore ]]
+rename = modspec sym "=>" sym => [[ first4 nip swapd add-renamed-word ignore ]]
+long = "{" ( from | exclude | rename | qualified-with | qualified ) "}" => [[ drop ignore ]]
+short = modspec => [[ use-vocab ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: peg.ebnf help.syntax help.markup strings ;
+IN: peg-lexer
+
+HELP: ON-BNF:
+{ $syntax "ON-BNF: word ... ;ON-BNF" }
+{ $description "Creates a parsing word using a parser for lexer control, adding the resulting ast to the stack. Parser syntax is as in " { $link POSTPONE: EBNF: } } ;
+
+HELP: create-bnf
+{ $values { "name" string } { "parser" parser } }
+{ $description "Runtime equivalent of " { $link POSTPONE: ON-BNF: } " also useful with manually constructed parsers." } ;
+
+HELP: factor
+{ $values { "input" string } { "ast" "a sequence of tokens" } }
+{ $description "Tokenizer that acts like standard factor lexer, separating tokens by whitespace." } ;
\ No newline at end of file
--- /dev/null
+USING: tools.test peg-lexer.test-parsers ;
+IN: peg-lexer.tests
+
+{ V{ "1234" "-end" } } [
+ test1 1234-end
+] unit-test
+
+{ V{ 1234 53 } } [
+ test2 12345
+] unit-test
+
+{ V{ "heavy" "duty" "testing" } } [
+ test3 heavy duty testing
+] unit-test
\ No newline at end of file
--- /dev/null
+USING: hashtables assocs sequences locals math accessors multiline delegate strings
+delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
+words ;
+IN: peg-lexer
+
+TUPLE: lex-hash hash ;
+CONSULT: assoc-protocol lex-hash hash>> ;
+: <lex-hash> ( a -- lex-hash ) lex-hash boa ;
+
+: pos-or-0 ( neg? -- pos/0 ) dup 0 < [ drop 0 ] when ;
+
+:: prepare-pos ( v i -- c l )
+ [let | n [ i v head-slice ] |
+ v CHAR: \n n last-index -1 or 1 + -
+ n [ CHAR: \n = ] count 1 +
+ ] ;
+
+: store-pos ( v a -- )
+ input swap at prepare-pos
+ lexer get [ (>>line) ] keep (>>column) ;
+
+M: lex-hash set-at
+ swap {
+ { pos [ store-pos ] }
+ [ swap hash>> set-at ]
+ } case ;
+
+:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ;
+
+M: lex-hash at*
+ swap {
+ { input [ drop lexer get text>> "\n" join t ] }
+ { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
+ [ swap hash>> at* ]
+ } case ;
+
+: with-global-lexer ( quot -- result )
+ [
+ f lrstack set
+ V{ } clone error-stack set H{ } clone \ heads set
+ H{ } clone \ packrat set
+ ] f make-assoc <lex-hash>
+ swap bind ; inline
+
+: parse* ( parser -- ast )
+ compile
+ [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+ ast>> ; inline
+
+: create-bnf ( name parser -- )
+ reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
+ define-syntax word make-inline ;
+
+SYNTAX: ON-BNF:
+ CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
+ main swap at create-bnf ;
+
+! Tokenizer like standard factor lexer
+EBNF: factor
+space = " " | "\n" | "\t"
+spaces = space* => [[ drop ignore ]]
+chunk = (!(space) .)+ => [[ >string ]]
+expr = spaces chunk
+;EBNF
--- /dev/null
+Use peg to write parsing words
--- /dev/null
+extensions
+reflection
--- /dev/null
+USING: peg-lexer math.parser strings ;
+IN: peg-lexer.test-parsers
+
+ON-BNF: test1
+ num = [1-4]* => [[ >string ]]
+ expr = num ( "-end" | "-done" )
+;ON-BNF
+
+ON-BNF: test2
+ num = [1-4]* => [[ >string string>number ]]
+ expr= num [5-9]
+;ON-BNF
+
+ON-BNF: test3
+ tokenizer = <foreign factor>
+ expr= "heavy" "duty" "testing"
+;ON-BNF
\ No newline at end of file
collector.trace_cards(data->tenured,
card_points_to_aging,
simple_unmarker(card_mark_mask));
- collector.cheneys_algorithm();
+ collector.tenure_reachable_objects();
}
{
/* If collection fails here, do a to_tenured collection. */
current_gc->op = collect_aging_op;
std::swap(data->aging,data->aging_semispace);
- reset_generation(data->aging);
+ data->reset_generation(data->aging);
aging_collector collector(this);
collector.trace_contexts();
collector.trace_code_heap_roots(&code->points_to_aging);
collector.cheneys_algorithm();
+
update_code_heap_for_minor_gc(&code->points_to_aging);
- nursery.here = nursery.start;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
}
}
struct aging_policy {
factor_vm *parent;
- zone *aging, *tenured;
+ aging_space *aging;
+ tenured_space *tenured;
- aging_policy(factor_vm *parent_) :
+ explicit aging_policy(factor_vm *parent_) :
parent(parent_),
aging(parent->data->aging),
tenured(parent->data->tenured) {}
{
return !(aging->contains_p(untagged) || tenured->contains_p(untagged));
}
+
+ void promoted_object(object *obj) {}
+
+ void visited_object(object *obj) {}
};
struct aging_collector : copying_collector<aging_space,aging_policy> {
- aging_collector(factor_vm *parent_);
+ explicit aging_collector(factor_vm *parent_);
};
}
namespace factor
{
-struct aging_space : old_space {
- aging_space(cell size, cell start) : old_space(size,start) {}
+struct aging_space : bump_allocator<object> {
+ object_start_map starts;
+
+ explicit aging_space(cell size, cell start) :
+ bump_allocator<object>(size,start), starts(size,start) {}
+
+ object *allot(cell size)
+ {
+ if(here + size > end) return NULL;
+
+ object *obj = bump_allocator<object>::allot(size);
+ starts.record_object_start_offset(obj);
+ return obj;
+ }
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((object *)scan)->size();
+ if(scan + size < here)
+ return scan + size;
+ else
+ return 0;
+ }
};
}
array *factor_vm::allot_array(cell capacity, cell fill_)
{
gc_root<object> fill(fill_,this);
- gc_root<array> new_array(allot_
array_internal<array>(capacity),this);
+ gc_root<array> new_array(allot_
uninitialized_array<array>(capacity),this);
if(fill.value() == tag_fixnum(0))
memset(new_array->data(),'\0',capacity * sizeof(cell));
cell factor_vm::allot_array_1(cell obj_)
{
gc_root<object> obj(obj_,this);
- gc_root<array> a(allot_
array_internal<array>(1),this);
+ gc_root<array> a(allot_
uninitialized_array<array>(1),this);
set_array_nth(a.untagged(),0,obj.value());
return a.value();
}
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
- gc_root<array> a(allot_
array_internal<array>(2),this);
+ gc_root<array> a(allot_
uninitialized_array<array>(2),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
return a.value();
gc_root<object> v2(v2_,this);
gc_root<object> v3(v3_,this);
gc_root<object> v4(v4_,this);
- gc_root<array> a(allot_
array_internal<array>(4),this);
+ gc_root<array> a(allot_
uninitialized_array<array>(4),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
set_array_nth(a.untagged(),2,v3.value());
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(array->h.hi_tag() == ARRAY_TYPE);
- check_tagged_pointer(value);
#endif
cell *slot_ptr = &array->data()[slot];
*slot_ptr = value;
bignum *factor_vm::allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum * result = allot_array_internal<bignum>(length + 1);
+ bignum * result = allot_uninitialized_array<bignum>(length + 1);
BIGNUM_SET_NEGATIVE_P (result, negative_p);
return (result);
}
--- /dev/null
+namespace factor
+{
+
+template<typename Block> struct bump_allocator {
+ /* offset of 'here' and 'end' is hardcoded in compiler backends */
+ cell here;
+ cell start;
+ cell end;
+ cell size;
+
+ explicit bump_allocator(cell size_, cell start_) :
+ here(start_), start(start_), end(start_ + size_), size(size_) {}
+
+ inline bool contains_p(Block *block)
+ {
+ return ((cell)block - start) < size;
+ }
+
+ inline Block *allot(cell size)
+ {
+ cell h = here;
+ here = h + align(size,data_alignment);
+ return (Block *)h;
+ }
+};
+
+}
byte_array *factor_vm::allot_byte_array(cell size)
{
- byte_array *array = allot_array_internal<byte_array>(size);
+ byte_array *array = allot_uninitialized_array<byte_array>(size);
memset(array + 1,0,size);
return array;
}
void factor_vm::primitive_uninitialized_byte_array()
{
cell size = unbox_array_size();
- dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
+ dpush(tag<byte_array>(allot_uninitialized_array<byte_array>(size)));
}
void factor_vm::primitive_resize_byte_array()
void callback_heap::update(callback *stub)
{
- tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
+ tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
callback *callback_heap::add(code_block *compiled)
{
- tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
+ tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
tagged<byte_array> insns(array_nth(code_template.untagged(),0));
cell size = array_capacity(insns.untagged());
- cell bump = align8(size) + sizeof(callback);
+ cell bump = align(size,sizeof(cell)) + sizeof(callback);
if(here + bump > seg->end) fatal_error("Out of callback space",0);
callback *stub = (callback *)here;
stub->compiled = compiled;
memcpy(stub + 1,insns->data<void>(),size);
- stub->size = align8(size);
+ stub->size = align(size,sizeof(cell));
here += bump;
update(stub);
return (code_block *)frame->xt - 1;
}
-cell factor_vm::frame_type(stack_frame *frame)
+code_block_type factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type();
}
{
switch(frame_type(frame))
{
- case QUOTATION_TYPE:
+ case code_block_unoptimized:
{
cell quot = frame_executing(frame);
if(to_boolean(quot))
else
return false_object;
}
- case WORD_TYPE:
+ case code_block_optimized:
return false_object;
default:
critical_error("Bad frame type",frame_type(frame));
if(parent->relocation_type_of(rel) == RT_IMMEDIATE)
{
cell offset = parent->relocation_offset_of(rel) + (cell)(compiled + 1);
- array *literals =
parent->untag<array>(compiled->literals);
+ array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
parent->store_address_in_code_block(parent->relocation_class_of(rel),offset,absolute_value);
}
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
- else if(compiled->type() == PIC_TYPE)
+ else if(compiled->pic_p())
code->code_heap_free(compiled);
else
{
}
};
-void factor_vm::update_code_block_for_full_gc(code_block *compiled)
+void factor_vm::update_code_block_words_and_literals(code_block *compiled)
{
if(code->needs_fixup_p(compiled))
relocate_code_block(compiled);
}
/* Might GC */
-code_block *factor_vm::allot_code_block(cell size, cell type)
+code_block *factor_vm::allot_code_block(cell size, code_block_type type)
{
- heap_block *block = code->heap_allot(size + sizeof(code_block),type);
+ code_block *block = code->allocator->allot(size + sizeof(code_block));
/* If allocation failed, do a full GC and compact the code heap.
A full GC that occurs as a result of the data heap filling up does not
if(block == NULL)
{
primitive_compact_gc();
- block = code->heap_allot(size + sizeof(code_block),type);
+ block = code->allocator->allot(size + sizeof(code_block));
/* Insufficient room even after code GC, give up */
if(block == NULL)
{
cell used, total_free, max_free;
- code->heap_usage(&used,&total_free,&max_free);
+ code->allocator->usage(&used,&total_free,&max_free);
- print_string("Code heap stats:\n");
- print_string("Used: "); print_cell(used); nl();
- print_string("Total free space: "); print_cell(total_free); nl();
- print_string("Largest free block: "); print_cell(max_free); nl();
+ std::cout << "Code heap stats:\n";
+ std::cout << "Used: " << used << "\n";
+ std::cout << "Total free space: " << total_free << "\n";
+ std::cout << "Largest free block: " << max_free << "\n";
fatal_error("Out of memory in add-compiled-block",0);
}
}
- return (code_block *)block;
+ block->set_type(type);
+ return block;
}
/* Might GC */
-code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
+code_block *factor_vm::add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
{
gc_root<byte_array> code(code_,this);
gc_root<object> labels(labels_,this);
gc_root<byte_array> relocation(relocation_,this);
gc_root<array> literals(literals_,this);
- cell code_length = align8(array_capacity(code.untagged()));
+ cell code_length = array_capacity(code.untagged());
code_block *compiled = allot_code_block(code_length,type);
compiled->owner = owner.value();
--- /dev/null
+namespace factor
+{
+
+template<typename Visitor> struct call_frame_code_block_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit call_frame_code_block_visitor(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void operator()(stack_frame *frame)
+ {
+ cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
+
+ code_block *new_block = visitor(parent->frame_code(frame));
+ frame->xt = new_block->xt();
+
+ FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
+ }
+};
+
+template<typename Visitor> struct callback_code_block_visitor {
+ callback_heap *callbacks;
+ Visitor visitor;
+
+ explicit callback_code_block_visitor(callback_heap *callbacks_, Visitor visitor_) :
+ callbacks(callbacks_), visitor(visitor_) {}
+
+ void operator()(callback *stub)
+ {
+ stub->compiled = visitor(stub->compiled);
+ callbacks->update(stub);
+ }
+};
+
+template<typename Visitor> struct code_block_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit code_block_visitor(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+ void visit_object_code_block(object *obj)
+ {
+ switch(obj->h.hi_tag())
+ {
+ case WORD_TYPE:
+ {
+ word *w = (word *)obj;
+ if(w->code)
+ w->code = visitor(w->code);
+ if(w->profiling)
+ w->code = visitor(w->profiling);
+
+ parent->update_word_xt(w);
+ break;
+ }
+ case QUOTATION_TYPE:
+ {
+ quotation *q = (quotation *)obj;
+ if(q->code)
+ parent->set_quot_xt(q,visitor(q->code));
+ break;
+ }
+ case CALLSTACK_TYPE:
+ {
+ callstack *stack = (callstack *)obj;
+ call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ parent->iterate_callstack_object(stack,call_frame_visitor);
+ break;
+ }
+ }
+ }
+
+ void visit_context_code_blocks()
+ {
+ call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ parent->iterate_active_frames(call_frame_visitor);
+ }
+
+ void visit_callback_code_blocks()
+ {
+ callback_code_block_visitor<Visitor> callback_visitor(parent->callbacks,visitor);
+ parent->callbacks->iterate(callback_visitor);
+ }
+
+};
+
+}
namespace factor
{
-code_heap::code_heap(bool secure_gc, cell size) : heap(secure_gc,size,true) {}
+code_heap::code_heap(cell size)
+{
+ if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
+ seg = new segment(align_page(size),true);
+ if(!seg) fatal_error("Out of memory in heap allocator",size);
+ allocator = new free_list_allocator<code_block>(size,seg->start);
+}
+
+code_heap::~code_heap()
+{
+ delete allocator;
+ allocator = NULL;
+ delete seg;
+ seg = NULL;
+}
void code_heap::write_barrier(code_block *compiled)
{
return needs_fixup.count(compiled) > 0;
}
+bool code_heap::marked_p(code_block *compiled)
+{
+ return allocator->state.marked_p(compiled);
+}
+
+void code_heap::set_marked_p(code_block *compiled)
+{
+ allocator->state.set_marked_p(compiled);
+}
+
+void code_heap::clear_mark_bits()
+{
+ allocator->state.clear_mark_bits();
+}
+
void code_heap::code_heap_free(code_block *compiled)
{
points_to_nursery.erase(compiled);
points_to_aging.erase(compiled);
needs_fixup.erase(compiled);
- heap_free(compiled);
+ allocator->free(compiled);
}
/* Allocate a code heap during startup */
void factor_vm::init_code_heap(cell size)
{
- code = new code_heap(secure_gc,size);
+ code = new code_heap(size);
}
bool factor_vm::in_code_heap_p(cell ptr)
factor_vm *parent;
explicit word_updater(factor_vm *parent_) : parent(parent_) {}
- void operator()(code_block *compiled)
+
+ void operator()(code_block *compiled, cell size)
{
parent->update_word_references(compiled);
}
iterate_code_heap(updater);
}
+/* After a full GC that did not grow the heap, we have to update references
+to literals and other words. */
+struct word_and_literal_code_heap_updater {
+ factor_vm *parent;
+
+ explicit word_and_literal_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+
+ void operator()(code_block *block, cell size)
+ {
+ parent->update_code_block_words_and_literals(block);
+ }
+};
+
+void factor_vm::update_code_heap_words_and_literals()
+{
+ word_and_literal_code_heap_updater updater(this);
+ code->allocator->sweep(updater);
+}
+
+/* After growing the heap, we have to perform a full relocation to update
+references to card and deck arrays. */
+struct code_heap_relocator {
+ factor_vm *parent;
+
+ explicit code_heap_relocator(factor_vm *parent_) : parent(parent_) {}
+
+ void operator()(code_block *block, cell size)
+ {
+ parent->relocate_code_block(block);
+ }
+};
+
+void factor_vm::relocate_code_heap()
+{
+ code_heap_relocator relocator(this);
+ code->allocator->sweep(relocator);
+}
+
void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
- WORD_TYPE,
+ code_block_optimized,
code,
labels,
owner,
break;
}
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
update_code_heap_words();
/* Push the free space and total size of the code heap */
void factor_vm::primitive_code_room()
{
- cell used, total_free, max_free;
- code->heap_usage(&used,&total_free,&max_free);
- dpush(tag_fixnum(code->seg->size / 1024));
- dpush(tag_fixnum(used / 1024));
- dpush(tag_fixnum(total_free / 1024));
- dpush(tag_fixnum(max_free / 1024));
-}
-
-code_block *code_heap::forward_code_block(code_block *compiled)
-{
- code_block *block1 = (code_block *)state->forward_block(compiled);
- code_block *block2 = (code_block *)forwarding[compiled];
- printf("%lx %lx\n",block1,block2);
- assert(block1 == block2);
- return block2;
-}
-
-struct callframe_forwarder {
- factor_vm *parent;
-
- explicit callframe_forwarder(factor_vm *parent_) : parent(parent_) {}
-
- void operator()(stack_frame *frame)
- {
- cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
-
- code_block *forwarded = parent->code->forward_code_block(parent->frame_code(frame));
- frame->xt = forwarded->xt();
-
- FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
- }
-};
-
-void factor_vm::forward_object_xts()
-{
- begin_scan();
-
- cell obj;
-
- while(to_boolean(obj = next_object()))
- {
- switch(tagged<object>(obj).type())
- {
- case WORD_TYPE:
- {
- word *w = untag<word>(obj);
-
- if(w->code)
- w->code = code->forward_code_block(w->code);
- if(w->profiling)
- w->profiling = code->forward_code_block(w->profiling);
-
- update_word_xt(obj);
- }
- break;
- case QUOTATION_TYPE:
- {
- quotation *quot = untag<quotation>(obj);
-
- if(quot->code)
- {
- quot->code = code->forward_code_block(quot->code);
- set_quot_xt(quot,quot->code);
- }
- }
- break;
- case CALLSTACK_TYPE:
- {
- callstack *stack = untag<callstack>(obj);
- callframe_forwarder forwarder(this);
- iterate_callstack_object(stack,forwarder);
- }
- break;
- default:
- break;
- }
- }
-
- end_scan();
-}
-
-void factor_vm::forward_context_xts()
-{
- callframe_forwarder forwarder(this);
- iterate_active_frames(forwarder);
-}
+ growable_array a(this);
-struct callback_forwarder {
- code_heap *code;
- callback_heap *callbacks;
-
- callback_forwarder(code_heap *code_, callback_heap *callbacks_) :
- code(code_), callbacks(callbacks_) {}
+ cell used, total_free, max_free;
+ code->allocator->usage(&used,&total_free,&max_free);
- void operator()(callback *stub)
- {
- stub->compiled = code->forward_code_block(stub->compiled);
- callbacks->update(stub);
- }
-};
+ a.add(tag_fixnum(code->seg->size >> 10));
+ a.add(tag_fixnum(used >> 10));
+ a.add(tag_fixnum(total_free >> 10));
+ a.add(tag_fixnum(max_free >> 10));
-void factor_vm::forward_callback_xts()
-{
- callback_forwarder forwarder(code,callbacks);
- callbacks->iterate(forwarder);
-}
-
-/* Move all free space to the end of the code heap. Live blocks must be marked
-on entry to this function. XTs in code blocks must be updated after this
-function returns. */
-void factor_vm::compact_code_heap(bool trace_contexts_p)
-{
- code->compact_heap();
- forward_object_xts();
- if(trace_contexts_p)
- {
- forward_context_xts();
- forward_callback_xts();
- }
+ a.trim();
+ dpush(a.elements.value());
}
struct stack_trace_stripper {
explicit stack_trace_stripper() {}
- void operator()(code_block *compiled)
+ void operator()(code_block *compiled, cell size)
{
compiled->owner = false_object;
}
namespace factor
{
-struct code_heap : heap {
+struct code_heap {
+ /* The actual memory area */
+ segment *seg;
+
+ /* Memory allocator */
+ free_list_allocator<code_block> *allocator;
+
/* Set of blocks which need full relocation. */
std::set<code_block *> needs_fixup;
/* Code blocks which may reference objects in aging space or the nursery */
std::set<code_block *> points_to_aging;
- explicit code_heap(bool secure_gc, cell size);
+ explicit code_heap(cell size);
+ ~code_heap();
void write_barrier(code_block *compiled);
void clear_remembered_set();
bool needs_fixup_p(code_block *compiled);
+ bool marked_p(code_block *compiled);
+ void set_marked_p(code_block *compiled);
+ void clear_mark_bits();
void code_heap_free(code_block *compiled);
- code_block *forward_code_block(code_block *compiled);
};
}
namespace factor
{
-template<typename TargetGeneration, typename Policy> struct collector {
+template<typename TargetGeneration, typename Policy> struct collector_workhorse {
factor_vm *parent;
- data_heap *data;
- code_heap *code;
- gc_state *current_gc;
generation_statistics *stats;
TargetGeneration *target;
Policy policy;
- explicit collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
+ explicit collector_workhorse(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
- data(parent_->data),
- code(parent_->code),
- current_gc(parent_->current_gc),
stats(stats_),
target(target_),
policy(policy_) {}
return untagged;
}
- void trace_handle(cell *handle)
+ object *promote_object(object *untagged)
{
- cell pointer = *handle;
-
- if(immediate_p(pointer)) return;
+ cell size = untagged->size();
+ object *newpointer = target->allot(size);
+ /* XXX not exception-safe */
+ if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
- object *untagged = parent->untag<object>(pointer);
- if(!policy.should_copy_p(untagged))
- return;
+ memcpy(newpointer,untagged,size);
+ untagged->h.forward_to(newpointer);
- object *forwarding = resolve_forwarding(untagged);
+ stats->object_count++;
+ stats->bytes_copied += size;
- if(forwarding == untagged)
- untagged = promote_object(untagged);
- else if(policy.should_copy_p(forwarding))
- untagged = promote_object(forwarding);
- else
- untagged = forwarding;
+ policy.promoted_object(newpointer);
- *handle = RETAG(untagged,TAG(pointer));
+ return newpointer;
}
- void trace_slots(object *ptr)
+ object *visit_object(object *obj)
{
- cell *slot = (cell *)ptr;
- cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr));
+ if(!policy.should_copy_p(obj))
+ {
+ policy.visited_object(obj);
+ return obj;
+ }
- if(slot != end)
+ object *forwarding = resolve_forwarding(obj);
+
+ if(forwarding == obj)
+ return promote_object(obj);
+ else if(policy.should_copy_p(forwarding))
+ return promote_object(forwarding);
+ else
{
- slot++;
- for(; slot < end; slot++) trace_handle(slot);
+ policy.visited_object(forwarding);
+ return forwarding;
}
}
+};
- object *promote_object(object *untagged)
- {
- cell size = parent->untagged_object_size(untagged);
- object *newpointer = target->allot(size);
- /* XXX not exception-safe */
- if(!newpointer) longjmp(current_gc->gc_unwind,1);
+template<typename TargetGeneration, typename Policy>
+inline static slot_visitor<collector_workhorse<TargetGeneration,Policy> > make_collector_workhorse(
+ factor_vm *parent,
+ generation_statistics *stats,
+ TargetGeneration *target,
+ Policy policy)
+{
+ return slot_visitor<collector_workhorse<TargetGeneration,Policy> >(parent,
+ collector_workhorse<TargetGeneration,Policy>(parent,stats,target,policy));
+}
- memcpy(newpointer,untagged,size);
- untagged->h.forward_to(newpointer);
+template<typename TargetGeneration, typename Policy> struct collector {
+ factor_vm *parent;
+ data_heap *data;
+ code_heap *code;
+ generation_statistics *stats;
+ TargetGeneration *target;
+ slot_visitor<collector_workhorse<TargetGeneration,Policy> > workhorse;
- stats->object_count++;
- stats->bytes_copied += size;
+ explicit collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
+ parent(parent_),
+ data(parent_->data),
+ code(parent_->code),
+ stats(stats_),
+ target(target_),
+ workhorse(make_collector_workhorse(parent_,stats_,target_,policy_)) {}
- return newpointer;
+ void trace_handle(cell *handle)
+ {
+ workhorse.visit_handle(handle);
}
- void trace_stack_elements(segment *region, cell *top)
+ void trace_slots(object *ptr)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- trace_handle(ptr);
+ workhorse.visit_slots(ptr);
}
- void trace_registered_locals()
+ void trace_roots()
{
- std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
- std::vector<cell>::const_iterator end = parent->gc_locals.end();
+ workhorse.visit_roots();
+ }
- for(; iter < end; iter++)
- trace_handle((cell *)(*iter));
+ void trace_contexts()
+ {
+ workhorse.visit_contexts();
}
- void trace_registered_bignums()
+ /* Trace all literals referenced from a code block. Only for aging and nursery collections */
+ void trace_literal_references(code_block *compiled)
{
- std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
- std::vector<cell>::const_iterator end = parent->gc_bignums.end();
+ workhorse.visit_literal_references(compiled);
+ }
- for(; iter < end; iter++)
- {
- cell *handle = (cell *)(*iter);
+ void trace_code_heap_roots(std::set<code_block *> *remembered_set)
+ {
+ std::set<code_block *>::const_iterator iter = remembered_set->begin();
+ std::set<code_block *>::const_iterator end = remembered_set->end();
- if(*handle)
- {
- *handle |= BIGNUM_TYPE;
- trace_handle(handle);
- *handle &= ~BIGNUM_TYPE;
- }
+ for(; iter != end; iter++)
+ {
+ trace_literal_references(*iter);
+ parent->gc_stats.code_blocks_scanned++;
}
}
- /* Copy roots over at the start of GC, namely various constants, stacks,
- the user environment and extra roots registered by local_roots.hpp */
- void trace_roots()
+ inline cell first_card_in_deck(cell deck)
{
- trace_handle(&parent->true_object);
- trace_handle(&parent->bignum_zero);
- trace_handle(&parent->bignum_pos_one);
- trace_handle(&parent->bignum_neg_one);
+ return deck << (deck_bits - card_bits);
+ }
- trace_registered_locals();
- trace_registered_bignums();
+ inline cell last_card_in_deck(cell deck)
+ {
+ return first_card_in_deck(deck + 1);
+ }
- for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]);
+ inline cell card_deck_for_address(cell a)
+ {
+ return addr_to_deck(a - data->start);
}
- void trace_contexts()
+ inline cell card_start_address(cell card)
+ {
+ return (card << card_bits) + data->start;
+ }
+
+ inline cell card_end_address(cell card)
{
- context *ctx = parent->ctx;
+ return ((card + 1) << card_bits) + data->start;
+ }
- while(ctx)
+ void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
+ {
+ if(card_start < end)
{
- trace_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
- trace_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+ start += sizeof(cell);
+
+ if(start < card_start) start = card_start;
+ if(end > card_end) end = card_end;
- trace_handle(&ctx->catchstack_save);
- trace_handle(&ctx->current_callback_save);
+ cell *slot_ptr = (cell *)start;
+ cell *end_ptr = (cell *)end;
- ctx = ctx->next;
+ if(slot_ptr != end_ptr)
+ {
+ for(; slot_ptr < end_ptr; slot_ptr++)
+ workhorse.visit_handle(slot_ptr);
+ }
+ }
+ }
+
+ template<typename SourceGeneration, typename Unmarker>
+ void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
+ {
+ u64 start_time = current_micros();
+
+ card_deck *decks = data->decks;
+ card_deck *cards = data->cards;
+
+ cell gen_start_card = addr_to_card(gen->start - data->start);
+
+ cell first_deck = card_deck_for_address(gen->start);
+ cell last_deck = card_deck_for_address(gen->end);
+
+ cell start = 0, binary_start = 0, end = 0;
+
+ for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
+ {
+ if(decks[deck_index] & mask)
+ {
+ parent->gc_stats.decks_scanned++;
+
+ cell first_card = first_card_in_deck(deck_index);
+ cell last_card = last_card_in_deck(deck_index);
+
+ for(cell card_index = first_card; card_index < last_card; card_index++)
+ {
+ if(cards[card_index] & mask)
+ {
+ parent->gc_stats.cards_scanned++;
+
+ if(end < card_start_address(card_index))
+ {
+ start = gen->starts.find_object_containing_card(card_index - gen_start_card);
+ binary_start = start + ((object *)start)->binary_payload_start();
+ end = start + ((object *)start)->size();
+ }
+
+#ifdef FACTOR_DEBUG
+ assert(addr_to_card(start - data->start) <= card_index);
+ assert(start < card_end_address(card_index));
+#endif
+
+scan_next_object: {
+ trace_partial_objects(
+ start,
+ binary_start,
+ card_start_address(card_index),
+ card_end_address(card_index));
+ if(end < card_end_address(card_index))
+ {
+ start = gen->next_object_after(start);
+ if(start)
+ {
+ binary_start = start + ((object *)start)->binary_payload_start();
+ end = start + ((object *)start)->size();
+ goto scan_next_object;
+ }
+ }
+ }
+
+ unmarker(&cards[card_index]);
+
+ if(!start) goto end;
+ }
+ }
+
+ unmarker(&decks[deck_index]);
+ }
}
+
+end: parent->gc_stats.card_scan_time += (current_micros() - start_time);
}
};
--- /dev/null
+#include "master.hpp"
+
+namespace factor {
+
+struct object_slot_forwarder {
+ mark_bits<object> *forwarding_map;
+
+ explicit object_slot_forwarder(mark_bits<object> *forwarding_map_) :
+ forwarding_map(forwarding_map_) {}
+
+ object *visit_object(object *obj)
+ {
+ return forwarding_map->forward_block(obj);
+ }
+};
+
+struct code_block_forwarder {
+ mark_bits<code_block> *forwarding_map;
+
+ explicit code_block_forwarder(mark_bits<code_block> *forwarding_map_) :
+ forwarding_map(forwarding_map_) {}
+
+ code_block *operator()(code_block *compiled)
+ {
+ return forwarding_map->forward_block(compiled);
+ }
+};
+
+static inline cell tuple_size_with_forwarding(mark_bits<object> *forwarding_map, object *obj)
+{
+ /* The tuple layout may or may not have been forwarded already. Tricky. */
+ object *layout_obj = (object *)UNTAG(((tuple *)obj)->layout);
+ tuple_layout *layout;
+
+ if(layout_obj < obj)
+ {
+ /* It's already been moved up; dereference through forwarding
+ map to get the size */
+ layout = (tuple_layout *)forwarding_map->forward_block(layout_obj);
+ }
+ else
+ {
+ /* It hasn't been moved up yet; dereference directly */
+ layout = (tuple_layout *)layout_obj;
+ }
+
+ return tuple_size(layout);
+}
+
+struct compaction_sizer {
+ mark_bits<object> *forwarding_map;
+
+ explicit compaction_sizer(mark_bits<object> *forwarding_map_) :
+ forwarding_map(forwarding_map_) {}
+
+ cell operator()(object *obj)
+ {
+ if(obj->free_p() || obj->h.hi_tag() != TUPLE_TYPE)
+ return obj->size();
+ else
+ return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
+ }
+};
+
+struct object_compaction_updater {
+ factor_vm *parent;
+ slot_visitor<object_slot_forwarder> slot_forwarder;
+ code_block_visitor<code_block_forwarder> code_forwarder;
+ mark_bits<object> *data_forwarding_map;
+ object_start_map *starts;
+
+ explicit object_compaction_updater(factor_vm *parent_,
+ slot_visitor<object_slot_forwarder> slot_forwarder_,
+ code_block_visitor<code_block_forwarder> code_forwarder_,
+ mark_bits<object> *data_forwarding_map_) :
+ parent(parent_),
+ slot_forwarder(slot_forwarder_),
+ code_forwarder(code_forwarder_),
+ data_forwarding_map(data_forwarding_map_),
+ starts(&parent->data->tenured->starts) {}
+
+ void operator()(object *old_address, object *new_address, cell size)
+ {
+ cell payload_start;
+ if(old_address->h.hi_tag() == TUPLE_TYPE)
+ payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
+ else
+ payload_start = old_address->binary_payload_start();
+
+ memmove(new_address,old_address,size);
+
+ slot_forwarder.visit_slots(new_address,payload_start);
+ code_forwarder.visit_object_code_block(new_address);
+ starts->record_object_start_offset(new_address);
+ }
+};
+
+struct code_block_compaction_updater {
+ factor_vm *parent;
+ slot_visitor<object_slot_forwarder> slot_forwarder;
+
+ explicit code_block_compaction_updater(factor_vm *parent_, slot_visitor<object_slot_forwarder> slot_forwarder_) :
+ parent(parent_), slot_forwarder(slot_forwarder_) {}
+
+ void operator()(code_block *old_address, code_block *new_address, cell size)
+ {
+ memmove(new_address,old_address,size);
+ slot_forwarder.visit_literal_references(new_address);
+ parent->relocate_code_block(new_address);
+ }
+};
+
+void factor_vm::collect_compact_impl(bool trace_contexts_p)
+{
+ tenured_space *tenured = data->tenured;
+ mark_bits<object> *data_forwarding_map = &tenured->state;
+ mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
+
+ /* Figure out where blocks are going to go */
+ data_forwarding_map->compute_forwarding();
+ code_forwarding_map->compute_forwarding();
+
+ /* Update root pointers */
+ slot_visitor<object_slot_forwarder> slot_forwarder(this,object_slot_forwarder(data_forwarding_map));
+ code_block_visitor<code_block_forwarder> code_forwarder(this,code_block_forwarder(code_forwarding_map));
+
+ /* Object start offsets get recomputed by the object_compaction_updater */
+ data->tenured->starts.clear_object_start_offsets();
+
+ /* Slide everything in tenured space up, and update data and code heap
+ pointers inside objects. */
+ object_compaction_updater object_updater(this,slot_forwarder,code_forwarder,data_forwarding_map);
+ compaction_sizer object_sizer(data_forwarding_map);
+ tenured->compact(object_updater,object_sizer);
+
+ /* Slide everything in the code heap up, and update data and code heap
+ pointers inside code blocks. */
+ code_block_compaction_updater code_block_updater(this,slot_forwarder);
+ standard_sizer<code_block> code_block_sizer;
+ code->allocator->compact(code_block_updater,code_block_sizer);
+
+ slot_forwarder.visit_roots();
+ if(trace_contexts_p)
+ {
+ slot_forwarder.visit_contexts();
+ code_forwarder.visit_context_code_blocks();
+ code_forwarder.visit_callback_code_blocks();
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+}
new_ctx->magic_frame = magic_frame;
- /* save per-callback userenv */
- new_ctx->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
- new_ctx->catchstack_save = userenv[CATCHSTACK_ENV];
+ /* save per-callback special_objects */
+ new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
+ new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
new_ctx->next = ctx;
ctx = new_ctx;
ds = ctx->datastack_save;
rs = ctx->retainstack_save;
- /* restore per-callback userenv */
- userenv[CURRENT_CALLBACK_ENV] = ctx->current_callback_save;
- userenv[CATCHSTACK_ENV] = ctx->catchstack_save;
+ /* restore per-callback special_objects */
+ special_objects[OBJ_CURRENT_CALLBACK] = ctx->current_callback_save;
+ special_objects[OBJ_CATCHSTACK] = ctx->catchstack_save;
context *old_ctx = ctx;
ctx = old_ctx->next;
return false;
else
{
- array *a = allot_
array_internal<array>(depth / sizeof(cell));
+ array *a = allot_
uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth);
dpush(tag<array>(a));
return true;
/* memory region holding current retain stack */
segment *retainstack_region;
- /* saved userenv slots on entry to callback */
+ /* saved special_objects slots on entry to callback */
cell catchstack_save;
cell current_callback_save;
struct simple_unmarker {
card unmask;
- simple_unmarker(card unmask_) : unmask(unmask_) {}
+ explicit simple_unmarker(card unmask_) : unmask(unmask_) {}
void operator()(card *ptr) { *ptr &= ~unmask; }
};
explicit copying_collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(parent_,stats_,target_,policy_), scan(target_->here) {}
- inline cell first_card_in_deck(cell deck)
- {
- return deck << (deck_bits - card_bits);
- }
-
- inline cell last_card_in_deck(cell deck)
- {
- return first_card_in_deck(deck + 1);
- }
-
- inline cell card_deck_for_address(cell a)
- {
- return addr_to_deck(a - this->data->start);
- }
-
- inline cell card_start_address(cell card)
- {
- return (card << card_bits) + this->data->start;
- }
-
- inline cell card_end_address(cell card)
- {
- return ((card + 1) << card_bits) + this->data->start;
- }
-
- void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
- {
- if(card_start < end)
- {
- start += sizeof(cell);
-
- if(start < card_start) start = card_start;
- if(end > card_end) end = card_end;
-
- cell *slot_ptr = (cell *)start;
- cell *end_ptr = (cell *)end;
-
- if(slot_ptr != end_ptr)
- {
- for(; slot_ptr < end_ptr; slot_ptr++)
- this->trace_handle(slot_ptr);
- }
- }
- }
-
- template<typename SourceGeneration, typename Unmarker>
- void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
- {
- u64 start_time = current_micros();
-
- card_deck *decks = this->data->decks;
- card_deck *cards = this->data->cards;
-
- cell gen_start_card = addr_to_card(gen->start - this->data->start);
-
- cell first_deck = card_deck_for_address(gen->start);
- cell last_deck = card_deck_for_address(gen->end);
-
- cell start = 0, binary_start = 0, end = 0;
-
- for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
- {
- if(decks[deck_index] & mask)
- {
- this->parent->gc_stats.decks_scanned++;
-
- cell first_card = first_card_in_deck(deck_index);
- cell last_card = last_card_in_deck(deck_index);
-
- for(cell card_index = first_card; card_index < last_card; card_index++)
- {
- if(cards[card_index] & mask)
- {
- this->parent->gc_stats.cards_scanned++;
-
- if(end < card_start_address(card_index))
- {
- start = gen->find_object_containing_card(card_index - gen_start_card);
- binary_start = start + this->parent->binary_payload_start((object *)start);
- end = start + this->parent->untagged_object_size((object *)start);
- }
-
-#ifdef FACTOR_DEBUG
- assert(addr_to_card(start - this->data->start) <= card_index);
- assert(start < card_end_address(card_index));
-#endif
-
-scan_next_object: {
- trace_partial_objects(
- start,
- binary_start,
- card_start_address(card_index),
- card_end_address(card_index));
- if(end < card_end_address(card_index))
- {
- start = gen->next_object_after(this->parent,start);
- if(start)
- {
- binary_start = start + this->parent->binary_payload_start((object *)start);
- end = start + this->parent->untagged_object_size((object *)start);
- goto scan_next_object;
- }
- }
- }
-
- unmarker(&cards[card_index]);
-
- if(!start) goto end;
- }
- }
-
- unmarker(&decks[deck_index]);
- }
- }
-
-end: this->parent->gc_stats.card_scan_time += (current_micros() - start_time);
- }
-
- /* Trace all literals referenced from a code block. Only for aging and nursery collections */
- void trace_literal_references(code_block *compiled)
- {
- this->trace_handle(&compiled->owner);
- this->trace_handle(&compiled->literals);
- this->trace_handle(&compiled->relocation);
- this->parent->gc_stats.code_blocks_scanned++;
- }
-
- void trace_code_heap_roots(std::set<code_block *> *remembered_set)
- {
- std::set<code_block *>::const_iterator iter = remembered_set->begin();
- std::set<code_block *>::const_iterator end = remembered_set->end();
-
- for(; iter != end; iter++) trace_literal_references(*iter);
- }
-
void cheneys_algorithm()
{
while(scan && scan < this->target->here)
{
this->trace_slots((object *)scan);
- scan = this->target->next_object_after(this->parent,scan);
+ scan = this->target->next_object_after(scan);
}
}
};
aging_size = aging_size_;
tenured_size = tenured_size_;
- cell total_size = young_size + 2 * aging_size + 2 * tenured_size;
+ cell total_size = young_size + 2 * aging_size + tenured_size;
total_size += deck_size;
cards = new card[cards_size];
cards_end = cards + cards_size;
+ memset(cards,0,cards_size);
cell decks_size = addr_to_deck(total_size);
decks = new card_deck[decks_size];
decks_end = decks + decks_size;
+ memset(decks,0,decks_size);
start = align(seg->start,deck_size);
tenured = new tenured_space(tenured_size,start);
- tenured_semispace = new tenured_space(tenured_size,tenured->end);
- aging = new aging_space(aging_size,tenured_semispace->end);
+ aging = new aging_space(aging_size,tenured->end);
aging_semispace = new aging_space(aging_size,aging->end);
- nursery = new zone(young_size,aging_semispace->end);
+ nursery = new nursery_space(young_size,aging_semispace->end);
assert(seg->end - nursery->end <= deck_size);
}
delete aging;
delete aging_semispace;
delete tenured;
- delete tenured_semispace;
delete[] cards;
delete[] decks;
}
return new data_heap(young_size,aging_size,new_tenured_size);
}
-void factor_vm::clear_cards(old_space *gen)
+template<typename Generation> void data_heap::clear_cards(Generation *gen)
{
- cell first_card = addr_to_card(gen->start - data->start);
- cell last_card = addr_to_card(gen->end - data->start);
- memset(&data->cards[first_card],0,last_card - first_card);
+ cell first_card = addr_to_card(gen->start - start);
+ cell last_card = addr_to_card(gen->end - start);
+ memset(&cards[first_card],0,last_card - first_card);
}
-void factor_vm::clear_decks(old_space *gen)
+template<typename Generation> void data_heap::clear_decks(Generation *gen)
{
- cell first_deck = addr_to_deck(gen->start - data->start);
- cell last_deck = addr_to_deck(gen->end - data->start);
- memset(&data->decks[first_deck],0,last_deck - first_deck);
+ cell first_deck = addr_to_deck(gen->start - start);
+ cell last_deck = addr_to_deck(gen->end - start);
+ memset(&decks[first_deck],0,last_deck - first_deck);
}
-/* After garbage collection, any generations which are now empty need to have
-their allocation pointers and cards reset. */
-void factor_vm::reset_generation(old_space *gen)
+void data_heap::reset_generation(nursery_space *gen)
{
gen->here = gen->start;
- if(secure_gc) memset((void*)gen->start,69,gen->size);
+}
+
+void data_heap::reset_generation(aging_space *gen)
+{
+ gen->here = gen->start;
+ clear_cards(gen);
+ clear_decks(gen);
+ gen->starts.clear_object_start_offsets();
+}
+void data_heap::reset_generation(tenured_space *gen)
+{
clear_cards(gen);
clear_decks(gen);
- gen->clear_object_start_offsets();
}
void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = *data->nursery;
- nursery.here = nursery.start;
init_card_decks();
- reset_generation(data->aging);
- reset_generation(data->tenured);
}
-void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_)
+void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size)
{
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
- secure_gc = secure_gc_;
}
/* Size of the object pointed to by a tagged pointer */
if(immediate_p(tagged))
return 0;
else
- return untagged_object_size(untag<object>(tagged));
+ return untag<object>(tagged)->size();
}
/* Size of the object pointed to by an untagged pointer */
-cell factor_vm::untagged_object_size(object *pointer)
+cell object::size() const
{
- return align8(unaligned_object_size(pointer));
-}
+ if(free_p()) return ((free_heap_block *)this)->size();
-/* Size of the data area of an object pointed to by an untagged pointer */
-cell factor_vm::unaligned_object_size(object *pointer)
-{
- switch(pointer->h.hi_tag())
+ switch(h.hi_tag())
{
case ARRAY_TYPE:
- return array_size((array*)pointer);
+ return align(array_size((array*)this),data_alignment);
case BIGNUM_TYPE:
- return array_size((bignum*)pointer);
+ return align(array_size((bignum*)this),data_alignment);
case BYTE_ARRAY_TYPE:
- return array_size((byte_array*)pointer);
+ return align(array_size((byte_array*)this),data_alignment);
case STRING_TYPE:
- return string_size(string_capacity((string*)pointer));
+ return align(string_size(string_capacity((string*)this)),data_alignment);
case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ {
+ tuple_layout *layout = (tuple_layout *)UNTAG(((tuple *)this)->layout);
+ return align(tuple_size(layout),data_alignment);
+ }
case QUOTATION_TYPE:
- return sizeof(quotation);
+ return align(sizeof(quotation),data_alignment);
case WORD_TYPE:
- return sizeof(word);
+ return align(sizeof(word),data_alignment);
case FLOAT_TYPE:
- return sizeof(boxed_float);
+ return align(sizeof(boxed_float),data_alignment);
case DLL_TYPE:
- return sizeof(dll);
+ return align(sizeof(dll),data_alignment);
case ALIEN_TYPE:
- return sizeof(alien);
+ return align(sizeof(alien),data_alignment);
case WRAPPER_TYPE:
- return sizeof(wrapper);
+ return align(sizeof(wrapper),data_alignment);
case CALLSTACK_TYPE:
- return callstack_size(untag_fixnum(((callstack *)pointer)->length));
+ return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
default:
- critical_error("Invalid header",(cell)pointer);
+ critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
-void factor_vm::primitive_size()
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
-cell factor_vm::binary_payload_start(object *pointer)
+cell object::binary_payload_start() const
{
- switch(pointer->h.hi_tag())
+ switch(h.hi_tag())
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
return sizeof(string);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
- return array_size<array>(array_capacity((array*)pointer));
+ return array_size<array>(array_capacity((array*)this));
case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ return tuple_size(untag<tuple_layout>(((tuple *)this)->layout));
case WRAPPER_TYPE:
return sizeof(wrapper);
default:
- critical_error("Invalid header",(cell)pointer);
+ critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
+void factor_vm::primitive_size()
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
/* Push memory usage statistics in data heap */
void factor_vm::primitive_data_room()
{
- dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
- dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
-
growable_array a(this);
- a.add(tag_fixnum((nursery.end - nursery.here) >> 10));
a.add(tag_fixnum((nursery.size) >> 10));
+ a.add(tag_fixnum((nursery.here - nursery.start) >> 10));
+ a.add(tag_fixnum((nursery.end - nursery.here) >> 10));
- a.add(tag_fixnum((data->aging->end - data->aging->here) >> 10));
a.add(tag_fixnum((data->aging->size) >> 10));
+ a.add(tag_fixnum((data->aging->here - data->aging->start) >> 10));
+ a.add(tag_fixnum((data->aging->end - data->aging->here) >> 10));
- a.add(tag_fixnum((data->tenured->end - data->tenured->here) >> 10));
- a.add(tag_fixnum((data->tenured->size) >> 10));
+ cell used, total_free, max_free;
+ data->tenured->usage(&used,&total_free,&max_free);
+ a.add(tag_fixnum(data->tenured->size >> 10));
+ a.add(tag_fixnum(used >> 10));
+ a.add(tag_fixnum(total_free >> 10));
+ a.add(tag_fixnum(max_free >> 10));
+
+ a.add(tag_fixnum((data->cards_end - data->cards) >> 10));
+ a.add(tag_fixnum((data->decks_end - data->decks) >> 10));
+ a.add(tag_fixnum((data->tenured->mark_stack.capacity()) >> 10));
a.trim();
dpush(a.elements.value());
/* Disables GC and activates next-object ( -- obj ) primitive */
void factor_vm::begin_scan()
{
- heap_scan_ptr = data->tenured->start;
+ heap_scan_ptr = data->tenured->first_object();
gc_off = true;
}
if(!gc_off)
general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL);
- if(heap_scan_ptr >= data->tenured->here)
+ if(heap_scan_ptr)
+ {
+ cell current = heap_scan_ptr;
+ heap_scan_ptr = data->tenured->next_object_after(heap_scan_ptr);
+ return tag_dynamic((object *)current);
+ }
+ else
return false_object;
-
- object *obj = (object *)heap_scan_ptr;
- heap_scan_ptr += untagged_object_size(obj);
- return tag_dynamic(obj);
}
/* Push object at heap scan cursor and advance; pushes f when done */
segment *seg;
- zone *nursery;
+ nursery_space *nursery;
aging_space *aging;
aging_space *aging_semispace;
tenured_space *tenured;
- tenured_space *tenured_semispace;
card *cards;
card *cards_end;
explicit data_heap(cell young_size, cell aging_size, cell tenured_size);
~data_heap();
data_heap *grow(cell requested_size);
+ template<typename Generation> void clear_cards(Generation *gen);
+ template<typename Generation> void clear_decks(Generation *gen);
+ void reset_generation(nursery_space *gen);
+ void reset_generation(aging_space *gen);
+ void reset_generation(tenured_space *gen);
};
}
namespace factor
{
-void factor_vm::print_chars(string* str)
+std::ostream &operator<<(std::ostream &out, const string *str)
{
- cell i;
- for(i = 0; i < string_capacity(str); i++)
- putchar(string_nth(str,i));
+ for(cell i = 0; i < string_capacity(str); i++)
+ out << (char)str->nth(i);
+ return out;
}
void factor_vm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
- {
- print_chars(untag<string>(word->vocabulary));
- print_string(":");
- }
+ std::cout << untag<string>(word->vocabulary) << ":";
if(tagged<object>(word->name).type_p(STRING_TYPE))
- print_chars(untag<string>(word->name));
+ std::cout << untag<string>(word->name);
else
{
- print_string("#<not a string: ");
+ std::cout << "#<not a string: ";
print_nested_obj(word->name,nesting);
- print_string(">");
+ std::cout << ">";
}
}
-void factor_vm::print_factor_string(string* str)
+void factor_vm::print_factor_string(string *str)
{
- putchar('"');
- print_chars(str);
- putchar('"');
+ std::cout << '"' << str << '"';
}
void factor_vm::print_array(array* array, cell nesting)
for(i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_tuple(tuple *tuple, cell nesting)
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
- print_string(" ");
+ std::cout << " ";
print_nested_obj(layout->klass,nesting);
- cell i;
bool trimmed;
-
if(length > 10 && !full_output)
{
trimmed = true;
else
trimmed = false;
- for(i = 0; i < length; i++)
+ for(cell i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(tuple->data()[i],nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
- print_string(" ... ");
+ std::cout << " ... ";
return;
}
switch(tagged<object>(obj).type())
{
case FIXNUM_TYPE:
- print_fixnum(untag_fixnum(obj));
+ std::cout << untag_fixnum(obj);
break;
case WORD_TYPE:
print_word(untag<word>(obj),nesting - 1);
print_factor_string(untag<string>(obj));
break;
case F_TYPE:
- print_string("f");
+ std::cout << "f";
break;
case TUPLE_TYPE:
- print_string("T{");
+ std::cout << "T{";
print_tuple(untag<tuple>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case ARRAY_TYPE:
- print_string("{");
+ std::cout << "{";
print_array(untag<array>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case QUOTATION_TYPE:
- print_string("[");
+ std::cout << "[";
quot = untag<quotation>(obj);
print_array(untag<array>(quot->array),nesting - 1);
- print_string(" ]");
+ std::cout << " ]";
break;
default:
- print_string("#<type ");
- print_cell(tagged<object>(obj).type());
- print_string(" @ ");
- print_cell_hex(obj);
- print_string(">");
+ std::cout << "#<type " << tagged<object>(obj).type() << " @ ";
+ std::cout << std::hex << obj << std::dec << ">";
break;
}
}
for(; start <= end; start++)
{
print_obj(*start);
- nl();
+ std::cout << std::endl;
}
}
void factor_vm::print_datastack()
{
- print_string("==== DATA STACK:\n");
+ std::cout << "==== DATA STACK:\n";
print_objects((cell *)ds_bot,(cell *)ds);
}
void factor_vm::print_retainstack()
{
- print_string("==== RETAIN STACK:\n");
+ std::cout << "==== RETAIN STACK:\n";
print_objects((cell *)rs_bot,(cell *)rs);
}
void operator()(stack_frame *frame)
{
parent->print_obj(parent->frame_executing(frame));
- print_string("\n");
+ std::cout << std::endl;
parent->print_obj(parent->frame_scan(frame));
- print_string("\n");
- print_string("word/quot addr: ");
- print_cell_hex((cell)parent->frame_executing(frame));
- print_string("\n");
- print_string("word/quot xt: ");
- print_cell_hex((cell)frame->xt);
- print_string("\n");
- print_string("return address: ");
- print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,parent));
- print_string("\n");
+ std::cout << std::endl;
+ std::cout << "word/quot addr: ";
+ std::cout << std::hex << (cell)parent->frame_executing(frame) << std::dec;
+ std::cout << std::endl;
+ std::cout << "word/quot xt: ";
+ std::cout << std::hex << (cell)frame->xt << std::dec;
+ std::cout << std::endl;
+ std::cout << "return address: ";
+ std::cout << std::hex << (cell)FRAME_RETURN_ADDRESS(frame,parent) << std::dec;
+ std::cout << std::endl;
}
};
void factor_vm::print_callstack()
{
- print_string("==== CALL STACK:\n");
+ std::cout << "==== CALL STACK:\n";
stack_frame_printer printer(this);
iterate_callstack(ctx,printer);
}
+struct padded_address {
+ cell value;
+
+ explicit padded_address(cell value_) : value(value_) {}
+};
+
+std::ostream &operator<<(std::ostream &out, const padded_address &value)
+{
+ char prev = out.fill('0');
+ out.width(sizeof(cell) * 2);
+ out << std::hex << value.value << std::dec;
+ out.fill(prev);
+ return out;
+}
+
void factor_vm::dump_cell(cell x)
{
- print_cell_hex_pad(x); print_string(": ");
+ std::cout << padded_address(x) << ": ";
x = *(cell *)x;
- print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x));
- nl();
+ std::cout << padded_address(x) << " tag " << TAG(x) << std::endl;
}
void factor_vm::dump_memory(cell from, cell to)
dump_cell(from);
}
-void factor_vm::dump_zone(const char *name, zone *z)
+template<typename Generation>
+void factor_vm::dump_generation(const char *name, Generation *gen)
{
- print_string(name); print_string(": ");
- print_string("Start="); print_cell(z->start);
- print_string(", size="); print_cell(z->size);
- print_string(", here="); print_cell(z->here - z->start); nl();
+ std::cout << name << ": ";
+ std::cout << "Start=" << gen->start;
+ std::cout << ", size=" << gen->size;
+ std::cout << ", end=" << gen->end;
+ std::cout << std::endl;
}
void factor_vm::dump_generations()
{
- dump_zone("Nursery",&nursery);
- dump_zone("Aging",data->aging);
- dump_zone("Tenured",data->tenured);
-
- print_string("Cards: base=");
- print_cell((cell)data->cards);
- print_string(", size=");
- print_cell((cell)(data->cards_end - data->cards));
- nl();
+ dump_generation("Nursery",&nursery);
+ dump_generation("Aging",data->aging);
+ dump_generation("Tenured",data->tenured);
+
+ std::cout << "Cards:";
+ std::cout << "base=" << (cell)data->cards << ", ";
+ std::cout << "size=" << (cell)(data->cards_end - data->cards) << std::endl;
}
void factor_vm::dump_objects(cell type)
{
if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
{
- print_cell_hex_pad(obj);
- print_string(" ");
+ std::cout << padded_address(obj) << " ";
print_nested_obj(obj,2);
- nl();
+ std::cout << std::endl;
}
}
{
if(look_for == *scan)
{
- print_cell_hex_pad(obj);
- print_string(" ");
+ std::cout << padded_address(obj) << " ";
parent->print_nested_obj(obj,2);
- nl();
+ std::cout << std::endl;
}
}
};
end_scan();
}
-/* Dump all code blocks for debugging */
-void factor_vm::dump_code_heap()
-{
- cell reloc_size = 0, literal_size = 0;
+struct code_block_printer {
+ factor_vm *parent;
+ cell reloc_size, literal_size;
- heap_block *scan = code->first_block();
- heap_block *end = code->last_block();
+ explicit code_block_printer(factor_vm *parent_) :
+ parent(parent_), reloc_size(0), literal_size(0) {}
- while(scan != end)
+ void operator()(code_block *scan, cell size)
{
const char *status;
- if(scan->type() == FREE_BLOCK_TYPE)
+ if(scan->free_p())
status = "free";
- else if(code->state->is_marked_p(scan))
+ else if(parent->code->marked_p(scan))
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "marked";
}
else
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "allocated";
}
- print_cell_hex((cell)scan); print_string(" ");
- print_cell_hex(scan->size()); print_string(" ");
- print_string(status); print_string("\n");
-
- scan = scan->next();
+ std::cout << std::hex << (cell)scan << std::dec << " ";
+ std::cout << std::hex << size << std::dec << " ";
+ std::cout << status << std::endl;
}
-
- print_cell(reloc_size); print_string(" bytes of relocation data\n");
- print_cell(literal_size); print_string(" bytes of literal data\n");
+};
+
+/* Dump all code blocks for debugging */
+void factor_vm::dump_code_heap()
+{
+ code_block_printer printer(this);
+ code->allocator->iterate(printer);
+ std::cout << printer.reloc_size << " bytes of relocation data\n";
+ std::cout << printer.literal_size << " bytes of literal data\n";
}
void factor_vm::factorbug()
{
if(fep_disabled)
{
- print_string("Low level debugger disabled\n");
+ std::cout << "Low level debugger disabled\n";
exit(1);
}
/* open_console(); */
- print_string("Starting low level debugger...\n");
- print_string(" Basic commands:\n");
- print_string("q -- continue executing Factor - NOT SAFE\n");
- print_string("im -- save image to fep.image\n");
- print_string("x -- exit Factor\n");
- print_string(" Advanced commands:\n");
- print_string("d <addr> <count> -- dump memory\n");
- print_string("u <addr> -- dump object at tagged <addr>\n");
- print_string(". <addr> -- print object at tagged <addr>\n");
- print_string("t -- toggle output trimming\n");
- print_string("s r -- dump data, retain stacks\n");
- print_string(".s .r .c -- print data, retain, call stacks\n");
- print_string("e -- dump environment\n");
- print_string("g -- dump generations\n");
- print_string("data -- data heap dump\n");
- print_string("words -- words dump\n");
- print_string("tuples -- tuples dump\n");
- print_string("refs <addr> -- find data heap references to object\n");
- print_string("push <addr> -- push object on data stack - NOT SAFE\n");
- print_string("code -- code heap dump\n");
+ std::cout << "Starting low level debugger...\n";
+ std::cout << " Basic commands:\n";
+ std::cout << "q -- continue executing Factor - NOT SAFE\n";
+ std::cout << "im -- save image to fep.image\n";
+ std::cout << "x -- exit Factor\n";
+ std::cout << " Advanced commands:\n";
+ std::cout << "d <addr> <count> -- dump memory\n";
+ std::cout << "u <addr> -- dump object at tagged <addr>\n";
+ std::cout << ". <addr> -- print object at tagged <addr>\n";
+ std::cout << "t -- toggle output trimming\n";
+ std::cout << "s r -- dump data, retain stacks\n";
+ std::cout << ".s .r .c -- print data, retain, call stacks\n";
+ std::cout << "e -- dump environment\n";
+ std::cout << "g -- dump generations\n";
+ std::cout << "data -- data heap dump\n";
+ std::cout << "words -- words dump\n";
+ std::cout << "tuples -- tuples dump\n";
+ std::cout << "refs <addr> -- find data heap references to object\n";
+ std::cout << "push <addr> -- push object on data stack - NOT SAFE\n";
+ std::cout << "code -- code heap dump\n";
bool seen_command = false;
{
char cmd[1024];
- print_string("READY\n");
+ std::cout << "READY\n";
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
{
cell addr = read_cell_hex();
print_obj(addr);
- print_string("\n");
+ std::cout << std::endl;
}
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
print_callstack();
else if(strcmp(cmd,"e") == 0)
{
- int i;
- for(i = 0; i < USER_ENV; i++)
- dump_cell((cell)&userenv[i]);
+ for(cell i = 0; i < special_object_count; i++)
+ dump_cell((cell)&special_objects[i]);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
else if(strcmp(cmd,"refs") == 0)
{
cell addr = read_cell_hex();
- print_string("Data heap references:\n");
+ std::cout << "Data heap references:\n";
find_data_references(addr);
- nl();
+ std::cout << std::endl;
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"code") == 0)
dump_code_heap();
else
- print_string("unknown command\n");
+ std::cout << "unknown command\n";
}
}
void factor_vm::primitive_die()
{
- print_string("The die word was called by the library. Unless you called it yourself,\n");
- print_string("you have triggered a bug in Factor. Please report.\n");
+ std::cout << "The die word was called by the library. Unless you called it yourself,\n";
+ std::cout << "you have triggered a bug in Factor. Please report.\n";
factorbug();
}
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
- emit_with(parent->userenv[MEGA_LOOKUP],cache.value());
+ emit_with(parent->special_objects[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(parent->userenv[MEGA_MISS_WORD]);
+ word_call(parent->special_objects[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
}
void fatal_error(const char *msg, cell tagged)
{
- print_string("fatal_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "fatal_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
exit(1);
}
void critical_error(const char *msg, cell tagged)
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("critical_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "critical_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
tls_vm()->factorbug();
}
void out_of_memory()
{
- print_string("Out of memory\n\n");
+ std::cout << "Out of memory\n\n";
tls_vm()->dump_generations();
exit(1);
}
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
- if(!current_gc && to_boolean(userenv[BREAK_ENV]))
+ if(!current_gc && to_boolean(special_objects[OBJ_BREAK]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
else
callstack_top = ctx->callstack_top;
- throw_impl(userenv[BREAK_ENV],callstack_top,this);
+ throw_impl(special_objects[OBJ_BREAK],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("early_error: ");
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "early_error: ";
print_obj(error);
- nl();
+ std::cout << std::endl;
factorbug();
}
}
void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
- throw_error(allot_array_4(userenv[ERROR_ENV],
+ throw_error(allot_array_4(special_objects[OBJ_ERROR],
tag_fixnum(error),arg1,arg2),callstack_top);
}
void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
- general_error(ERROR_SIGNAL,tag_fixnum(signal),false_object,native_stack);
+ general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack);
}
void factor_vm::divide_by_zero_error()
{
factor_vm *vm;
-unordered_map<THREADHANDLE, factor_vm*> thread_vms;
+std::map<THREADHANDLE, factor_vm*> thread_vms;
void init_globals()
{
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
- p->tenured_size = 4 * sizeof(cell);
+ p->tenured_size = 16 * sizeof(cell);
#endif
p->max_pic_size = 3;
- p->secure_gc = false;
p->fep = false;
+ p->verbosegc = false;
p->signals = true;
#ifdef WINDOWS
else if(factor_arg(arg,STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(factor_arg(arg,STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(factor_arg(arg,STRING_LITERAL("-callbacks=%d"),&p->callback_size));
- else if(STRCMP(arg,STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(arg,STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRCMP(arg,STRING_LITERAL("-nosignals")) == 0) p->signals = false;
+ else if(STRCMP(arg,STRING_LITERAL("-verbosegc")) == 0) p->verbosegc = true;
else if(STRNCMP(arg,STRING_LITERAL("-i="),3) == 0) p->image_path = arg + 3;
else if(STRCMP(arg,STRING_LITERAL("-console")) == 0) p->console = true;
}
/* Do some initialization that we do once only */
void factor_vm::do_stage1_init()
{
- print_string("*** Stage 2 early init... ");
+ std::cout << "*** Stage 2 early init... ";
fflush(stdout);
compile_all_words();
- userenv[STAGE2_ENV] = true_object;
+ special_objects[OBJ_STAGE2] = true_object;
- print_string("done\n");
- fflush(stdout);
+ std::cout << "done\n";
}
void factor_vm::init_factor(vm_parameters *p)
if(p->signals)
init_signals();
+ verbosegc = p->verbosegc;
+
if(p->console)
open_console();
init_profiler();
- userenv[CPU_ENV] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
- userenv[OS_ENV] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
- userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path);
- userenv[ARGS_ENV] = false_object;
- userenv[EMBEDDED_ENV] = false_object;
+ special_objects[OBJ_CPU] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
+ special_objects[OBJ_OS] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
+ special_objects[OBJ_CELL_SIZE] = tag_fixnum(sizeof(cell));
+ special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
+ special_objects[OBJ_ARGS] = false_object;
+ special_objects[OBJ_EMBEDDED] = false_object;
/* We can GC now */
gc_off = false;
- if(!to_boolean(userenv[STAGE2_ENV]))
+ if(!to_boolean(special_objects[OBJ_STAGE2]))
do_stage1_init();
}
}
args.trim();
- userenv[ARGS_ENV] = args.elements.value();
+ special_objects[OBJ_ARGS] = args.elements.value();
}
void factor_vm::start_factor(vm_parameters *p)
if(p->fep) factorbug();
nest_stacks(NULL);
- c_to_factor_toplevel(userenv[BOOT_ENV]);
+ c_to_factor_toplevel(special_objects[OBJ_BOOT]);
unnest_stacks();
}
char *factor_vm::factor_eval_string(char *string)
{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
return callback(string);
}
void factor_vm::factor_yield()
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
callback();
}
void factor_vm::factor_sleep(long us)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
callback(us);
}
--- /dev/null
+namespace factor
+{
+
+static const cell free_list_count = 32;
+
+struct free_heap_block
+{
+ cell header;
+ free_heap_block *next_free;
+
+ bool free_p() const
+ {
+ return header & 1 == 1;
+ }
+
+ cell size() const
+ {
+ return header >> 3;
+ }
+
+ void make_free(cell size)
+ {
+ header = (size << 3) | 1;
+ }
+};
+
+struct free_list {
+ free_heap_block *small_blocks[free_list_count];
+ free_heap_block *large_blocks;
+};
+
+template<typename Block> struct free_list_allocator {
+ cell size;
+ cell start;
+ cell end;
+ free_list free_blocks;
+ mark_bits<Block> state;
+
+ explicit free_list_allocator(cell size, cell start);
+ bool contains_p(Block *block);
+ Block *first_block();
+ Block *last_block();
+ Block *next_block_after(Block *block);
+ void clear_free_list();
+ void add_to_free_list(free_heap_block *block);
+ void initial_free_list(cell size);
+ void assert_free_block(free_heap_block *block);
+ free_heap_block *find_free_block(cell size);
+ free_heap_block *split_free_block(free_heap_block *block, cell size);
+ bool can_allot_p(cell size);
+ Block *allot(cell size);
+ void free(Block *block);
+ void usage(cell *used, cell *total_free, cell *max_free);
+ cell occupied();
+ void sweep();
+ template<typename Iterator> void sweep(Iterator &iter);
+ template<typename Iterator, typename Sizer> void compact(Iterator &iter, Sizer &sizer);
+ template<typename Iterator, typename Sizer> void iterate(Iterator &iter, Sizer &sizer);
+ template<typename Iterator> void iterate(Iterator &iter);
+};
+
+template<typename Block>
+free_list_allocator<Block>::free_list_allocator(cell size_, cell start_) :
+ size(size_), start(start_), end(start_ + size_), state(mark_bits<Block>(size_,start_))
+{
+ initial_free_list(0);
+}
+
+template<typename Block> void free_list_allocator<Block>::clear_free_list()
+{
+ memset(&free_blocks,0,sizeof(free_list));
+}
+
+template<typename Block> bool free_list_allocator<Block>::contains_p(Block *block)
+{
+ return ((cell)block - start) < size;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::first_block()
+{
+ return (Block *)start;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::last_block()
+{
+ return (Block *)end;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::next_block_after(Block *block)
+{
+ return (Block *)((cell)block + block->size());
+}
+
+template<typename Block> void free_list_allocator<Block>::add_to_free_list(free_heap_block *block)
+{
+ if(block->size() < free_list_count * block_granularity)
+ {
+ int index = block->size() / block_granularity;
+ block->next_free = free_blocks.small_blocks[index];
+ free_blocks.small_blocks[index] = block;
+ }
+ else
+ {
+ block->next_free = free_blocks.large_blocks;
+ free_blocks.large_blocks = block;
+ }
+}
+
+/* Called after reading the heap from the image file, and after heap compaction.
+Makes a free list consisting of one free block, at the very end. */
+template<typename Block> void free_list_allocator<Block>::initial_free_list(cell size)
+{
+ clear_free_list();
+ if(size != this->size)
+ {
+ free_heap_block *last_block = (free_heap_block *)(start + size);
+ last_block->make_free(end - (cell)last_block);
+ add_to_free_list(last_block);
+ }
+}
+
+template<typename Block> void free_list_allocator<Block>::assert_free_block(free_heap_block *block)
+{
+#ifdef FACTOR_DEBUG
+ assert(block->free_p());
+#endif
+}
+
+template<typename Block> free_heap_block *free_list_allocator<Block>::find_free_block(cell size)
+{
+ cell attempt = size;
+
+ while(attempt < free_list_count * block_granularity)
+ {
+ int index = attempt / block_granularity;
+ free_heap_block *block = free_blocks.small_blocks[index];
+ if(block)
+ {
+ assert_free_block(block);
+ free_blocks.small_blocks[index] = block->next_free;
+ return block;
+ }
+
+ attempt *= 2;
+ }
+
+ free_heap_block *prev = NULL;
+ free_heap_block *block = free_blocks.large_blocks;
+
+ while(block)
+ {
+ assert_free_block(block);
+ if(block->size() >= size)
+ {
+ if(prev)
+ prev->next_free = block->next_free;
+ else
+ free_blocks.large_blocks = block->next_free;
+ return block;
+ }
+
+ prev = block;
+ block = block->next_free;
+ }
+
+ return NULL;
+}
+
+template<typename Block> free_heap_block *free_list_allocator<Block>::split_free_block(free_heap_block *block, cell size)
+{
+ if(block->size() != size)
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->make_free(block->size() - size);
+ split->next_free = block->next_free;
+ block->make_free(size);
+ add_to_free_list(split);
+ }
+
+ return block;
+}
+
+template<typename Block> bool free_list_allocator<Block>::can_allot_p(cell size)
+{
+ cell attempt = size;
+
+ while(attempt < free_list_count * block_granularity)
+ {
+ int index = attempt / block_granularity;
+ if(free_blocks.small_blocks[index]) return true;
+ attempt *= 2;
+ }
+
+ free_heap_block *block = free_blocks.large_blocks;
+ while(block)
+ {
+ if(block->size() >= size) return true;
+ block = block->next_free;
+ }
+
+ return false;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::allot(cell size)
+{
+ size = align(size,block_granularity);
+
+ free_heap_block *block = find_free_block(size);
+ if(block)
+ {
+ block = split_free_block(block,size);
+ return (Block *)block;
+ }
+ else
+ return NULL;
+}
+
+template<typename Block> void free_list_allocator<Block>::free(Block *block)
+{
+ free_heap_block *free_block = (free_heap_block *)block;
+ free_block->make_free(block->size());
+ add_to_free_list(free_block);
+}
+
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+template<typename Block> void free_list_allocator<Block>::usage(cell *used, cell *total_free, cell *max_free)
+{
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
+ Block *scan = first_block();
+ Block *end = last_block();
+
+ while(scan != end)
+ {
+ cell size = scan->size();
+
+ if(scan->free_p())
+ {
+ *total_free += size;
+ if(size > *max_free)
+ *max_free = size;
+ }
+ else
+ *used += size;
+
+ scan = next_block_after(scan);
+ }
+}
+
+/* The size of the heap after compaction */
+template<typename Block> cell free_list_allocator<Block>::occupied()
+{
+ Block *scan = first_block();
+ Block *last = last_block();
+
+ while(scan != last)
+ {
+ if(scan->free_p()) break;
+ else scan = next_block_after(scan);
+ }
+
+ if(scan != last)
+ {
+ free_heap_block *free_block = (free_heap_block *)scan;
+ assert(free_block->free_p());
+ assert((cell)scan + free_block->size() == end);
+
+ return (cell)scan - (cell)first_block();
+ }
+ else
+ return size;
+}
+
+template<typename Block>
+void free_list_allocator<Block>::sweep()
+{
+ this->clear_free_list();
+
+ Block *prev = NULL;
+ Block *scan = this->first_block();
+ Block *end = this->last_block();
+
+ while(scan != end)
+ {
+ cell size = scan->size();
+
+ if(scan->free_p())
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ prev = scan;
+ }
+ else if(this->state.marked_p(scan))
+ {
+ if(prev && prev->free_p())
+ this->add_to_free_list((free_heap_block *)prev);
+ prev = scan;
+ }
+ else
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ {
+ free_heap_block *free_block = (free_heap_block *)scan;
+ free_block->make_free(size);
+ prev = scan;
+ }
+ }
+
+ scan = (Block *)((cell)scan + size);
+ }
+
+ if(prev && prev->free_p())
+ this->add_to_free_list((free_heap_block *)prev);
+}
+
+template<typename Block>
+template<typename Iterator>
+void free_list_allocator<Block>::sweep(Iterator &iter)
+{
+ this->clear_free_list();
+
+ Block *prev = NULL;
+ Block *scan = this->first_block();
+ Block *end = this->last_block();
+
+ while(scan != end)
+ {
+ cell size = scan->size();
+
+ if(scan->free_p())
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ prev = scan;
+ }
+ else if(this->state.marked_p(scan))
+ {
+ if(prev && prev->free_p())
+ this->add_to_free_list((free_heap_block *)prev);
+ prev = scan;
+ iter(scan,size);
+ }
+ else
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ {
+ free_heap_block *free_block = (free_heap_block *)scan;
+ free_block->make_free(size);
+ prev = scan;
+ }
+ }
+
+ scan = (Block *)((cell)scan + size);
+ }
+
+ if(prev && prev->free_p())
+ this->add_to_free_list((free_heap_block *)prev);
+}
+
+template<typename Block, typename Iterator> struct heap_compactor {
+ mark_bits<Block> *state;
+ char *address;
+ Iterator &iter;
+
+ explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_) :
+ state(state_), address((char *)address_), iter(iter_) {}
+
+ void operator()(Block *block, cell size)
+ {
+ if(this->state->marked_p(block))
+ {
+ iter(block,(Block *)address,size);
+ address += size;
+ }
+ }
+};
+
+/* The forwarding map must be computed first by calling
+state.compute_forwarding(). */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::compact(Iterator &iter, Sizer &sizer)
+{
+ heap_compactor<Block,Iterator> compactor(&state,first_block(),iter);
+ this->iterate(compactor,sizer);
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ this->initial_free_list((cell)compactor.address - this->start);
+}
+
+/* During compaction we have to be careful and measure object sizes differently */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::iterate(Iterator &iter, Sizer &sizer)
+{
+ Block *scan = first_block();
+ Block *end = last_block();
+
+ while(scan != end)
+ {
+ cell size = sizer(scan);
+ Block *next = (Block *)((cell)scan + size);
+ if(!scan->free_p()) iter(scan,size);
+ scan = next;
+ }
+}
+
+template<typename Block> struct standard_sizer {
+ cell operator()(Block *block)
+ {
+ return block->size();
+ }
+};
+
+template<typename Block>
+template<typename Iterator>
+void free_list_allocator<Block>::iterate(Iterator &iter)
+{
+ standard_sizer<Block> sizer;
+ iterate(iter,sizer);
+}
+
+}
{
full_collector::full_collector(factor_vm *parent_) :
- copying_collector<tenured_space,full_policy>(
+ collector<tenured_space,full_policy>(
parent_,
&parent_->gc_stats.full_stats,
parent_->data->tenured,
full_policy(parent_)) {}
-struct stack_frame_marker {
- factor_vm *parent;
+struct code_block_marker {
+ code_heap *code;
full_collector *collector;
- explicit stack_frame_marker(full_collector *collector_) :
- parent(collector_->parent), collector(collector_) {}
+ explicit code_block_marker(code_heap *code_, full_collector *collector_) :
+ code(code_), collector(collector_) {}
- void operator()(stack_frame *frame)
+ code_block *operator()(code_block *compiled)
{
- collector->mark_code_block(parent->frame_code(frame));
- }
-};
-
-/* Mark code blocks executing in currently active stack frames. */
-void full_collector::mark_active_blocks()
-{
- stack_frame_marker marker(this);
- parent->iterate_active_frames(marker);
-}
-
-void full_collector::mark_object_code_block(object *obj)
-{
- switch(obj->h.hi_tag())
- {
- case WORD_TYPE:
+ if(!code->marked_p(compiled))
{
- word *w = (word *)obj;
- if(w->code)
- mark_code_block(w->code);
- if(w->profiling)
- mark_code_block(w->profiling);
- break;
+ code->set_marked_p(compiled);
+ collector->trace_literal_references(compiled);
}
- case QUOTATION_TYPE:
- {
- quotation *q = (quotation *)obj;
- if(q->code)
- mark_code_block(q->code);
- break;
- }
- case CALLSTACK_TYPE:
- {
- callstack *stack = (callstack *)obj;
- stack_frame_marker marker(this);
- parent->iterate_callstack_object(stack,marker);
- break;
- }
- }
-}
-
-struct callback_tracer {
- full_collector *collector;
-
- callback_tracer(full_collector *collector_) : collector(collector_) {}
-
- void operator()(callback *stub)
- {
- collector->mark_code_block(stub->compiled);
- }
-};
-
-void full_collector::trace_callbacks()
-{
- callback_tracer tracer(this);
- parent->callbacks->iterate(tracer);
-}
-
-/* Trace all literals referenced from a code block. Only for aging and nursery collections */
-void full_collector::trace_literal_references(code_block *compiled)
-{
- this->trace_handle(&compiled->owner);
- this->trace_handle(&compiled->literals);
- this->trace_handle(&compiled->relocation);
-}
-
-/* Mark all literals referenced from a word XT. Only for tenured
-collections */
-void full_collector::mark_code_block(code_block *compiled)
-{
- this->code->mark_block(compiled);
- trace_literal_references(compiled);
-}
-
-void full_collector::cheneys_algorithm()
-{
- while(scan && scan < target->here)
- {
- object *obj = (object *)scan;
- this->trace_slots(obj);
- this->mark_object_code_block(obj);
- scan = target->next_object_after(this->parent,scan);
- }
-}
-/* After growing the heap, we have to perform a full relocation to update
-references to card and deck arrays. */
-struct big_code_heap_updater {
- factor_vm *parent;
-
- big_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
-
- void operator()(heap_block *block)
- {
- parent->relocate_code_block((code_block *)block);
+ return compiled;
}
};
-/* After a full GC that did not grow the heap, we have to update references
-to literals and other words. */
-struct small_code_heap_updater {
- factor_vm *parent;
+struct object_start_map_updater {
+ object_start_map *starts;
- small_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+ explicit object_start_map_updater(object_start_map *starts_) : starts(starts_) {}
- void operator()(heap_block *block)
+ void operator()(object *obj, cell size)
{
- parent->update_code_block_for_full_gc((code_block *)block);
+ starts->record_object_start_offset(obj);
}
};
-void factor_vm::collect_full_impl(bool trace_contexts_p)
+void factor_vm::collect_mark_impl(bool trace_contexts_p)
{
full_collector collector(this);
- code->state->clear_mark_bits();
+ code->clear_mark_bits();
+ data->tenured->clear_mark_bits();
+ data->tenured->clear_mark_stack();
+
+ code_block_visitor<code_block_marker> code_marker(this,code_block_marker(code,&collector));
collector.trace_roots();
if(trace_contexts_p)
{
collector.trace_contexts();
- collector.mark_active_blocks();
- collector.trace_callbacks();
+ code_marker.visit_context_code_blocks();
+ code_marker.visit_callback_code_blocks();
}
- collector.cheneys_algorithm();
-
- reset_generation(data->aging);
- nursery.here = nursery.start;
-}
-
-void factor_vm::collect_growing_heap(cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
-{
- /* Grow the data heap and copy all live objects to the new heap. */
- data_heap *old = data;
- set_data_heap(data->grow(requested_bytes));
- collect_full_impl(trace_contexts_p);
- delete old;
+ std::vector<object *> *mark_stack = &data->tenured->mark_stack;
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
- else
+ while(!mark_stack->empty())
{
- big_code_heap_updater updater(this);
- code->free_unmarked(updater);
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ collector.trace_slots(obj);
+ code_marker.visit_object_code_block(obj);
}
+ data->reset_generation(data->tenured);
+ data->reset_generation(data->aging);
+ data->reset_generation(&nursery);
code->clear_remembered_set();
}
-void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p)
+void factor_vm::collect_sweep_impl()
{
- /* Copy all live objects to the tenured semispace. */
- std::swap(data->tenured,data->tenured_semispace);
- reset_generation(data->tenured);
- collect_full_impl(trace_contexts_p);
-
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
- else
- {
- small_code_heap_updater updater(this);
- code->free_unmarked(updater);
- }
+ data->tenured->starts.clear_object_start_offsets();
+ object_start_map_updater updater(&data->tenured->starts);
+ data->tenured->sweep(updater);
+}
- code->clear_remembered_set();
+void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p)
+{
+ /* Grow the data heap and copy all live objects to the new heap. */
+ data_heap *old = data;
+ set_data_heap(data->grow(requested_bytes));
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_impl(trace_contexts_p);
+ delete old;
}
}
struct full_policy {
factor_vm *parent;
- zone *tenured;
+ tenured_space *tenured;
- full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
+ explicit full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_and_push(obj);
+ }
+
+ void visited_object(object *obj)
+ {
+ if(!tenured->marked_p(obj))
+ tenured->mark_and_push(obj);
+ }
};
-struct full_collector : copying_collector<tenured_space,full_policy> {
+struct full_collector : collector<tenured_space,full_policy> {
bool trace_contexts_p;
- full_collector(factor_vm *parent_);
- void mark_active_blocks();
- void mark_object_code_block(object *object);
- void trace_callbacks();
- void trace_literal_references(code_block *compiled);
- void mark_code_block(code_block *compiled);
- void cheneys_algorithm();
+ explicit full_collector(factor_vm *parent_);
};
}
stats->max_gc_time = gc_elapsed;
}
-void factor_vm::gc(gc_op op,
- cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
+void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
{
assert(!gc_off);
assert(!current_gc);
current_gc = new gc_state(op);
+ if(verbosegc)
+ std::cout << "GC requested, op=" << op << std::endl;
+
/* Keep trying to GC higher and higher generations until we don't run out
of space */
if(setjmp(current_gc->gc_unwind))
current_gc->op = collect_full_op;
break;
case collect_full_op:
+ case collect_compact_op:
current_gc->op = collect_growing_heap_op;
break;
default:
- critical_error("Bad GC op\n",op);
+ critical_error("Bad GC op",current_gc->op);
break;
}
+
+ if(verbosegc)
+ std::cout << "GC rewind, op=" << current_gc->op << std::endl;
}
switch(current_gc->op)
record_gc_stats(&gc_stats.aging_stats);
break;
case collect_full_op:
- collect_full(trace_contexts_p,compact_code_heap_p);
+ collect_mark_impl(trace_contexts_p);
+ collect_sweep_impl();
+ update_code_heap_words_and_literals();
+ record_gc_stats(&gc_stats.full_stats);
+ break;
+ case collect_compact_op:
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_impl(trace_contexts_p);
record_gc_stats(&gc_stats.full_stats);
break;
case collect_growing_heap_op:
- collect_growing_heap(requested_bytes,trace_contexts_p,compact_code_heap_p);
+ collect_growing_heap(requested_bytes,trace_contexts_p);
record_gc_stats(&gc_stats.full_stats);
break;
default:
- critical_error("Bad GC op\n",op);
+ critical_error("Bad GC op\n",current_gc->op);
break;
}
+ if(verbosegc)
+ std::cout << "GC done, op=" << current_gc->op << std::endl;
+
delete current_gc;
current_gc = NULL;
}
{
gc(collect_nursery_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_full_gc()
{
gc(collect_full_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_compact_gc()
{
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- true, /* trace contexts? */
- true /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::add_gc_stats(generation_statistics *stats, growable_array *result)
/* If the object is smaller than the nursery, allocate it in the nursery,
after a GC if needed */
- if(nursery.size > size)
+ if(size < nursery.size)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + size > nursery.end)
obj = nursery.allot(size);
}
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
else
{
- /* If tenured space does not have enough room, collect */
- if(data->tenured->here + size > data->tenured->end)
- primitive_full_gc();
-
- /* If it still won't fit, grow the heap */
- if(data->tenured->here + size > data->tenured->end)
+ /* If tenured space does not have enough room, collect and compact */
+ if(!data->tenured->can_allot_p(size))
{
- gc(collect_growing_heap_op,
- size, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ primitive_compact_gc();
+
+ /* If it still won't fit, grow the heap */
+ if(!data->tenured->can_allot_p(size))
+ {
+ gc(collect_growing_heap_op,
+ size, /* requested size */
+ true /* trace contexts? */);
+ }
}
obj = data->tenured->allot(size);
collect_aging_op,
collect_to_tenured_op,
collect_full_op,
+ collect_compact_op,
collect_growing_heap_op
};
namespace factor
{
-template<typename Array> cell array_capacity(Array *array)
+template<typename Array> cell array_capacity(const Array *array)
{
#ifdef FACTOR_DEBUG
assert(array->h.hi_tag() == Array::type_number);
return array_size<Array>(array_capacity(array));
}
-template<typename Array> Array *factor_vm::allot_array_internal(cell capacity)
+template<typename Array> Array *factor_vm::allot_uninitialized_array(cell capacity)
{
Array *array = allot<Array>(array_size<Array>(capacity));
array->capacity = tag_fixnum(capacity);
if(capacity < to_copy)
to_copy = capacity;
- Array *new_array = allot_
array_internal<Array>(capacity);
+ Array *new_array = allot_
uninitialized_array<Array>(capacity);
memcpy(new_array + 1,array.untagged() + 1,to_copy * Array::element_size);
memset((char *)(new_array + 1) + to_copy * Array::element_size,
+++ /dev/null
-#include "master.hpp"
-
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
-will be used for the data heap too, if we ever get mark/sweep/compact GC. */
-
-namespace factor
-{
-
-void heap::clear_free_list()
-{
- memset(&free,0,sizeof(heap_free_list));
-}
-
-heap::heap(bool secure_gc_, cell size, bool executable_p) : secure_gc(secure_gc_)
-{
- if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
- seg = new segment(align_page(size),executable_p);
- if(!seg) fatal_error("Out of memory in heap allocator",size);
- state = new mark_bits<heap_block,block_size_increment>(seg->start,size);
- clear_free_list();
-}
-
-heap::~heap()
-{
- delete seg;
- seg = NULL;
- delete state;
- state = NULL;
-}
-
-void heap::add_to_free_list(free_heap_block *block)
-{
- if(block->size() < free_list_count * block_size_increment)
- {
- int index = block->size() / block_size_increment;
- block->next_free = free.small_blocks[index];
- free.small_blocks[index] = block;
- }
- else
- {
- block->next_free = free.large_blocks;
- free.large_blocks = block;
- }
-}
-
-/* Called after reading the code heap from the image file, and after code heap
-compaction. Makes a free list consisting of one free block, at the very end. */
-void heap::build_free_list(cell size)
-{
- clear_free_list();
- free_heap_block *end = (free_heap_block *)(seg->start + size);
- end->set_type(FREE_BLOCK_TYPE);
- end->set_size(seg->end - (cell)end);
- add_to_free_list(end);
-}
-
-void heap::assert_free_block(free_heap_block *block)
-{
- if(block->type() != FREE_BLOCK_TYPE)
- critical_error("Invalid block in free list",(cell)block);
-}
-
-free_heap_block *heap::find_free_block(cell size)
-{
- cell attempt = size;
-
- while(attempt < free_list_count * block_size_increment)
- {
- int index = attempt / block_size_increment;
- free_heap_block *block = free.small_blocks[index];
- if(block)
- {
- assert_free_block(block);
- free.small_blocks[index] = block->next_free;
- return block;
- }
-
- attempt *= 2;
- }
-
- free_heap_block *prev = NULL;
- free_heap_block *block = free.large_blocks;
-
- while(block)
- {
- assert_free_block(block);
- if(block->size() >= size)
- {
- if(prev)
- prev->next_free = block->next_free;
- else
- free.large_blocks = block->next_free;
- return block;
- }
-
- prev = block;
- block = block->next_free;
- }
-
- return NULL;
-}
-
-free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
-{
- if(block->size() != size )
- {
- /* split the block in two */
- free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->set_type(FREE_BLOCK_TYPE);
- split->set_size(block->size() - size);
- split->next_free = block->next_free;
- block->set_size(size);
- add_to_free_list(split);
- }
-
- return block;
-}
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *heap::heap_allot(cell size, cell type)
-{
- size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
- free_heap_block *block = find_free_block(size);
- if(block)
- {
- block = split_free_block(block,size);
- block->set_type(type);
- return block;
- }
- else
- return NULL;
-}
-
-/* Deallocates a block manually */
-void heap::heap_free(heap_block *block)
-{
- block->set_type(FREE_BLOCK_TYPE);
- add_to_free_list((free_heap_block *)block);
-}
-
-void heap::mark_block(heap_block *block)
-{
- state->set_marked_p(block);
-}
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- heap_block *scan = first_block();
- heap_block *end = last_block();
-
- while(scan != end)
- {
- cell size = scan->size();
-
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- *total_free += size;
- if(size > *max_free)
- *max_free = size;
- }
- else
- *used += size;
-
- scan = scan->next();
- }
-}
-
-/* The size of the heap after compaction */
-cell heap::heap_size()
-{
- heap_block *scan = first_block();
- heap_block *end = last_block();
-
- while(scan != end)
- {
- if(scan->type() == FREE_BLOCK_TYPE) break;
- else scan = scan->next();
- }
-
- assert(scan->type() == FREE_BLOCK_TYPE);
- assert((cell)scan + scan->size() == seg->end);
-
- return (cell)scan - (cell)first_block();
-}
-
-void heap::compact_heap()
-{
- forwarding.clear();
- state->compute_forwarding();
-
- heap_block *scan = first_block();
- heap_block *end = last_block();
-
- char *address = (char *)scan;
-
- /* Slide blocks up while building the forwarding hashtable. */
- while(scan != end)
- {
- heap_block *next = scan->next();
-
- if(state->is_marked_p(scan))
- {
- cell size = scan->size();
- memmove(address,scan,size);
- forwarding[scan] = address;
- address += size;
- }
-
- scan = next;
- }
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list((cell)address - seg->start);
-}
-
-heap_block *heap::free_allocated(heap_block *prev, heap_block *scan)
-{
- if(secure_gc)
- memset(scan + 1,0,scan->size() - sizeof(heap_block));
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- {
- prev->set_size(prev->size() + scan->size());
- return prev;
- }
- else
- {
- scan->set_type(FREE_BLOCK_TYPE);
- return scan;
- }
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell free_list_count = 16;
-static const cell block_size_increment = 32;
-
-struct heap_free_list {
- free_heap_block *small_blocks[free_list_count];
- free_heap_block *large_blocks;
-};
-
-struct heap {
- bool secure_gc;
- segment *seg;
- heap_free_list free;
- mark_bits<heap_block,block_size_increment> *state;
- unordered_map<heap_block *, char *> forwarding;
-
- explicit heap(bool secure_gc_, cell size, bool executable_p);
- ~heap();
-
- inline heap_block *first_block()
- {
- return (heap_block *)seg->start;
- }
-
- inline heap_block *last_block()
- {
- return (heap_block *)seg->end;
- }
-
- void clear_free_list();
- void new_heap(cell size);
- void add_to_free_list(free_heap_block *block);
- void build_free_list(cell size);
- void assert_free_block(free_heap_block *block);
- free_heap_block *find_free_block(cell size);
- free_heap_block *split_free_block(free_heap_block *block, cell size);
- heap_block *heap_allot(cell size, cell type);
- void heap_free(heap_block *block);
- void mark_block(heap_block *block);
- void heap_usage(cell *used, cell *total_free, cell *max_free);
- cell heap_size();
- void compact_heap();
-
- heap_block *free_allocated(heap_block *prev, heap_block *scan);
-
- /* After code GC, all referenced code blocks have status set to B_MARKED, so any
- which are allocated and not marked can be reclaimed. */
- template<typename Iterator> void free_unmarked(Iterator &iter)
- {
- clear_free_list();
-
- heap_block *prev = NULL;
- heap_block *scan = first_block();
- heap_block *end = last_block();
-
- while(scan != end)
- {
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- prev->set_size(prev->size() + scan->size());
- else
- prev = scan;
- }
- else if(state->is_marked_p(scan))
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- prev = scan;
- iter(scan);
- }
- else
- prev = free_allocated(prev,scan);
-
- scan = scan->next();
- }
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- }
-};
-
-}
/* Certain special objects in the image are known to the runtime */
void factor_vm::init_objects(image_header *h)
{
- memcpy(userenv,h->userenv,sizeof(userenv));
+ memcpy(special_objects,h->special_objects,sizeof(special_objects));
true_object = h->true_object;
bignum_zero = h->bignum_zero;
void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
- cell good_size = h->data_size + (1 << 20);
-
- if(good_size > p->tenured_size)
- p->tenured_size = good_size;
+ p->tenured_size = std::max((h->data_size * 3) / 2,p->tenured_size);
init_data_heap(p->young_size,
p->aging_size,
- p->tenured_size,
- p->secure_gc);
+ p->tenured_size);
clear_gc_stats();
if((cell)bytes_read != h->data_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->data_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->data_size << " bytes expected\n";
fatal_error("load_data_heap failed",0);
}
- data->tenured->here = data->tenured->start + h->data_size;
+ data->tenured->initial_free_list(h->data_size);
}
void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
if(h->code_size != 0)
{
- size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
+ size_t bytes_read = fread(code->allocator->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->code_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->code_size << " bytes expected\n";
fatal_error("load_code_heap failed",0);
}
}
- code->build_free_list(h->code_size);
+ code->allocator->initial_free_list(h->code_size);
}
void factor_vm::data_fixup(cell *handle, cell data_relocation_base)
data_fixup(&t->layout,data_relocation_base);
cell *scan = t->data();
- cell *end = (cell *)((cell)object + untagged_object_size(object));
+ cell *end = (cell *)((cell)object + object->size());
for(; scan < end; scan++)
data_fixup(scan,data_relocation_base);
where it is loaded, we need to fix up pointers in the image. */
void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_base)
{
- for(cell i = 0; i < USER_ENV; i++)
- data_fixup(&userenv[i],data_relocation_base);
+ for(cell i = 0; i < special_object_count; i++)
+ data_fixup(&special_objects[i],data_relocation_base);
data_fixup(&true_object,data_relocation_base);
data_fixup(&bignum_zero,data_relocation_base);
while(obj)
{
relocate_object((object *)obj,data_relocation_base,code_relocation_base);
- data->tenured->record_object_start_offset((object *)obj);
- obj = data->tenured->next_object_after(this,obj);
+ data->tenured->starts.record_object_start_offset((object *)obj);
+ obj = data->tenured->next_object_after(obj);
}
}
factor_vm *parent;
cell data_relocation_base;
- code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
+ explicit code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
parent(parent_), data_relocation_base(data_relocation_base_) { }
- void operator()(code_block *compiled)
+ void operator()(code_block *compiled, cell size)
{
parent->fixup_code_block(compiled,data_relocation_base);
}
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << p->image_path << std::endl;
+ std::cout << strerror(errno) << std::endl;
exit(1);
}
relocate_code(h.data_relocation_base);
/* Store image path name */
- userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path);
+ special_objects[OBJ_IMAGE] = allot_alien(false_object,(cell)p->image_path);
}
/* Save the current image to disk */
file = OPEN_WRITE(filename);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(filename); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << filename << std::endl;
+ std::cout << strerror(errno) << std::endl;
return false;
}
h.magic = image_magic;
h.version = image_version;
h.data_relocation_base = data->tenured->start;
- h.data_size = data->tenured->here - data->tenured->start;
+ h.data_size = data->tenured->occupied();
h.code_relocation_base = code->seg->start;
- h.code_size = code->heap_size();
+ h.code_size = code->allocator->occupied();
h.true_object = true_object;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
- for(cell i = 0; i < USER_ENV; i++)
- h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
+ for(cell i = 0; i < special_object_count; i++)
+ h.special_objects[i] = (save_env_p(i) ? special_objects[i] : false_object);
bool ok = true;
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
+ if(fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
if(!ok)
- {
- print_string("save-image failed: "); print_string(strerror(errno)); nl();
- }
+ std::cout << "save-image failed: " << strerror(errno) << std::endl;
return ok;
}
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
- /* strip out userenv data which is set on startup anyway */
- for(cell i = 0; i < USER_ENV; i++)
- if(!save_env_p(i)) userenv[i] = false_object;
+ /* strip out special_objects data which is set on startup anyway */
+ for(cell i = 0; i < special_object_count; i++)
+ if(!save_env_p(i)) special_objects[i] = false_object;
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- false, /* discard objects only reachable from stacks */
- true /* compact the code heap */);
+ false /* discard objects only reachable from stacks */);
/* Save the image */
if(save_image((vm_char *)(path.untagged() + 1)))
/* tagged pointer to bignum -1 */
cell bignum_neg_one;
/* Initial user environment */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
};
struct vm_parameters {
cell ds_size, rs_size;
cell young_size, aging_size, tenured_size;
cell code_size;
- bool secure_gc;
bool fep;
+ bool verbosegc;
bool console;
bool signals;
cell max_pic_size;
check_code_pointer((cell)old_xt);
code_block *old_block = (code_block *)old_xt - 1;
- cell old_type = old_block->type();
-#ifdef FACTOR_DEBUG
- /* The call target was either another PIC,
- or a compiled quotation (megamorphic stub) */
- assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
-#endif
-
- if(old_type == PIC_TYPE)
+ /* Free the old PIC since we know its unreachable */
+ if(old_block->pic_p())
code->code_heap_free(old_block);
}
struct inline_cache_jit : public jit {
fixnum index;
- explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
+ explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(code_block_pic,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = parent->userenv[PIC_CHECK_TAG];
+ code_template = parent->special_objects[PIC_CHECK_TAG];
else
- code_template = parent->userenv[PIC_CHECK];
+ code_template = parent->special_objects[PIC_CHECK];
emit_with(code_template,klass);
}
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(parent->userenv[PIC_HIT],method);
+ emit_with(parent->special_objects[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(parent->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(parent->special_objects[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
set_call_target(return_address,xt);
#ifdef PIC_DEBUG
- printf("Updated %s call site 0x%lx with 0x%lx\n",
- tail_call_site_p(return_address) ? "tail" : "non-tail",
- return_address,
- (cell)xt);
+ std::cout << "Updated "
+ << (tail_call_site_p(return_address) ? "tail" : "non-tail")
+ << " call site 0x" << std::hex << return_address << std::dec
+ << " with " << std::hex << (cell)xt << std::dec;
#endif
return xt;
void factor_vm::init_c_io()
{
- userenv[STDIN_ENV] = allot_alien(false_object,(cell)stdin);
- userenv[STDOUT_ENV] = allot_alien(false_object,(cell)stdout);
- userenv[STDERR_ENV] = allot_alien(false_object,(cell)stderr);
+ special_objects[OBJ_STDIN] = allot_alien(false_object,(cell)stdin);
+ special_objects[OBJ_STDOUT] = allot_alien(false_object,(cell)stdout);
+ special_objects[OBJ_STDERR] = allot_alien(false_object,(cell)stderr);
}
void factor_vm::io_error()
return;
}
- gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
+ gc_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
for(;;)
{
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_, factor_vm *vm)
+jit::jit(code_block_type type_, cell owner_, factor_vm *vm)
: type(type_),
owner(owner_,vm),
code(vm),
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(parent->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(parent->userenv[type]);
+ emit_with(parent->special_objects[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(parent->special_objects[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
{
struct jit {
- cell type;
+ code_block_type type;
gc_root<object> owner;
growable_byte_array code;
growable_byte_array relocation;
cell offset;
factor_vm *parent;
- explicit jit(cell jit_type, cell owner, factor_vm *vm);
+ explicit jit(code_block_type type, cell owner, factor_vm *parent);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void literal(cell literal) { literals.add(literal); }
void emit_with(cell code_template_, cell literal_);
- void push(cell literal) {
- emit_with(parent->userenv[JIT_PUSH_IMMEDIATE],literal);
+ void push(cell literal)
+ {
+ emit_with(parent->special_objects[JIT_PUSH_IMMEDIATE],literal);
}
- void word_jump(cell word_) {
+ void word_jump(cell word_)
+ {
gc_root<word> word(word_,parent);
literal(tag_fixnum(xt_tail_pic_offset));
literal(word.value());
- emit(parent->userenv[JIT_WORD_JUMP]);
+ emit(parent->special_objects[JIT_WORD_JUMP]);
}
- void word_call(cell word) {
- emit_with(parent->userenv[JIT_WORD_CALL],word);
+ void word_call(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_CALL],word);
}
- void word_special(cell word) {
- emit_with(parent->userenv[JIT_WORD_SPECIAL],word);
+ void word_special(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_SPECIAL],word);
}
- void emit_subprimitive(cell word_) {
+ void emit_subprimitive(cell word_)
+ {
gc_root<word> word(word_,parent);
gc_root<array> code_pair(word->subprimitive,parent);
- literals.append(
parent->untag<array>(array_nth(code_pair.untagged(),0)));
+ literals.append(untag<array>(array_nth(code_pair.untagged(),0)));
emit(array_nth(code_pair.untagged(),1));
}
void emit_class_lookup(fixnum index, cell type);
- fixnum get_position() {
+ fixnum get_position()
+ {
if(computing_offset_p)
{
/* If this is still on, emit() didn't clear it,
return position;
}
- void set_position(fixnum position_) {
+ void set_position(fixnum position_)
+ {
if(computing_offset_p)
position = position_;
}
return (a + (b-1)) & ~(b-1);
}
-inline static cell align8(cell a)
-{
- return align(a,8);
-}
+static const cell data_alignment = 16;
#define WORD_SIZE (signed)(sizeof(cell)*8)
#define TYPE_COUNT 15
-/* Not real types, but code_block's type can be set to this */
-#define PIC_TYPE 16
-#define FREE_BLOCK_TYPE 17
+enum code_block_type
+{
+ code_block_unoptimized,
+ code_block_optimized,
+ code_block_profiling,
+ code_block_pic
+};
/* Constants used when floating-point trap exceptions are thrown */
enum
explicit header(cell value_) : value(value_ << TAG_BITS) {}
- void check_header() {
+ void check_header() const
+ {
#ifdef FACTOR_DEBUG
assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
#endif
}
- cell hi_tag() {
+ cell hi_tag() const
+ {
check_header();
return value >> TAG_BITS;
}
- bool forwarding_pointer_p() {
+ bool forwarding_pointer_p() const
+ {
return TAG(value) == GC_COLLECTED;
}
- object *forwarding_pointer() {
+ object *forwarding_pointer() const
+ {
return (object *)UNTAG(value);
}
- void forward_to(object *pointer) {
+ void forward_to(object *pointer)
+ {
value = RETAG(pointer,GC_COLLECTED);
}
};
struct object {
NO_TYPE_CHECK;
header h;
- cell *slots() { return (cell *)this; }
+
+ cell size() const;
+ cell binary_payload_start() const;
+
+ cell *slots() const { return (cell *)this; }
+
+ /* Only valid for objects in tenured space; must fast to free_heap_block
+ to do anything with it if its free */
+ bool free_p() const
+ {
+ return h.value & 1 == 1;
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
/* These are really just arrays, but certain elements have special
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
struct byte_array : public object {
/* tagged */
cell capacity;
- template<typename Scalar> Scalar *data() { return (Scalar *)(this + 1); }
+#ifndef FACTOR_64
+ cell padding0;
+ cell padding1;
+#endif
+
+ template<typename Scalar> Scalar *data() const { return (Scalar *)(this + 1); }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell hashcode;
- u8 *data() { return (u8 *)(this + 1); }
+ u8 *data() const { return (u8 *)(this + 1); }
+
+ cell nth(cell i) const;
};
/* The compiled code heap is structured into blocks. */
-struct heap_block
+struct code_block
{
cell header;
+ cell owner; /* tagged pointer to word, quotation or f */
+ cell literals; /* tagged pointer to array or f */
+ cell relocation; /* tagged pointer to byte-array or f */
- cell type() { return (header >> 1) & 0x1f; }
- void set_type(cell type)
+ bool free_p() const
{
- header = ((header & ~(0x1f << 1)) | (type << 1));
+ return header & 1 == 1;
}
- cell size() { return (header >> 6); }
- void set_size(cell size)
+ code_block_type type() const
{
- header = (header & 0x2f) | (size << 6);
+ return (code_block_type)((header >> 1) & 0x3);
}
- inline heap_block *next()
+ void set_type(code_block_type type)
{
- return (heap_block *)((cell)this + size());
+ header = ((header & ~0x7) | (type << 1));
}
-};
-struct free_heap_block : public heap_block
-{
- free_heap_block *next_free;
-};
+ bool pic_p() const
+ {
+ return type() == code_block_pic;
+ }
-struct code_block : public heap_block
-{
- cell owner; /* tagged pointer to word, quotation or f */
- cell literals; /* tagged pointer to array or f */
- cell relocation; /* tagged pointer to byte-array or f */
+ bool optimized_p() const
+ {
+ return type() == code_block_optimized;
+ }
- void *xt() { return (void *)(this + 1); }
+ cell size() const
+ {
+ return header >> 3;
+ }
+
+ void *xt() const
+ {
+ return (void *)(this + 1);
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell length;
- stack_frame *frame_at(cell offset)
+ stack_frame *frame_at(cell offset) const
{
return (stack_frame *)((char *)(this + 1) + offset);
}
- stack_frame *top() { return (stack_frame *)(this + 1); }
- stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+ stack_frame *top() const { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() const { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
};
struct tuple : public object {
/* tagged layout */
cell layout;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
}
{
factor_vm *parent;
- void push() { parent->check_tagged_pointer(tagged<Type>::value()); parent->gc_locals.push_back((cell)this); }
-
+ void push() { parent->gc_locals.push_back((cell)this); }
+
explicit gc_root(cell value_,factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
explicit gc_root(Type *value_, factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
else
signal_callstack_top = NULL;
- MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+ MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state));
/* Now we point the program counter at the right handler function. */
if(exception == EXC_BAD_ACCESS)
}
else
{
- signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
+ switch(exception)
+ {
+ case EXC_ARITHMETIC: signal_number = SIGFPE; break;
+ case EXC_BAD_INSTRUCTION: signal_number = SIGILL; break;
+ default: signal_number = SIGABRT; break;
+ }
+
MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl;
}
}
{
THREADHANDLE thread_id = pthread_from_mach_thread_np(thread);
assert(thread_id);
- unordered_map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
+ std::map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
if (vm != thread_vms.end())
vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state);
}
fatal_error("mach_port_insert_right() failed",0);
/* The exceptions we want to catch. */
- mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
+ mask = EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC;
/* Create the thread listening on the exception port. */
start_thread(mach_exception_thread,NULL);
namespace factor
{
+const int block_granularity = 16;
const int forwarding_granularity = 64;
-template<typename Block, int Granularity> struct mark_bits {
- cell start;
+template<typename Block> struct mark_bits {
cell size;
+ cell start;
cell bits_size;
u64 *marked;
- u64 *allocated;
cell *forwarding;
void clear_mark_bits()
memset(marked,0,bits_size * sizeof(u64));
}
- void clear_allocated_bits()
- {
- memset(allocated,0,bits_size * sizeof(u64));
- }
-
void clear_forwarding()
{
memset(forwarding,0,bits_size * sizeof(cell));
}
- explicit mark_bits(cell start_, cell size_) :
- start(start_),
+ explicit mark_bits(cell size_, cell start_) :
size(size_),
- bits_size(size / Granularity / forwarding_granularity),
+ start(start_),
+ bits_size(size / block_granularity / forwarding_granularity),
marked(new u64[bits_size]),
- allocated(new u64[bits_size]),
forwarding(new cell[bits_size])
{
clear_mark_bits();
- clear_allocated_bits();
clear_forwarding();
}
{
delete[] marked;
marked = NULL;
- delete[] allocated;
- allocated = NULL;
delete[] forwarding;
forwarding = NULL;
}
cell block_line(Block *address)
{
- return (((cell)address - start) / Granularity);
+ return (((cell)address - start) / block_granularity);
}
Block *line_block(cell line)
{
- return (Block *)(line * Granularity + start);
+ return (Block *)(line * block_granularity + start);
}
std::pair<cell,cell> bitmap_deref(Block *address)
cell line_number = block_line(address);
cell word_index = (line_number >> 6);
cell word_shift = (line_number & 63);
-
-#ifdef FACTOR_DEBUG
- assert(word_index < bits_size);
-#endif
-
return std::make_pair(word_index,word_shift);
}
return (bits[pair.first] & ((u64)1 << pair.second)) != 0;
}
+ Block *next_block_after(Block *block)
+ {
+ return (Block *)((cell)block + block->size());
+ }
+
void set_bitmap_range(u64 *bits, Block *address)
{
std::pair<cell,cell> start = bitmap_deref(address);
- std::pair<cell,cell> end = bitmap_deref(address->next());
+ std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
u64 start_mask = ((u64)1 << start.second) - 1;
u64 end_mask = ((u64)1 << end.second) - 1;
bits[start.first] |= start_mask ^ end_mask;
else
{
+#ifdef FACTOR_DEBUG
+ assert(start.first < bits_size);
+#endif
bits[start.first] |= ~start_mask;
- if(end.first != 0)
+ for(cell index = start.first + 1; index < end.first; index++)
+ bits[index] = (u64)-1;
+
+ if(end_mask != 0)
{
- for(cell index = start.first + 1; index < end.first - 1; index++)
- bits[index] = (u64)-1;
+#ifdef FACTOR_DEBUG
+ assert(end.first < bits_size);
+#endif
+ bits[end.first] |= end_mask;
}
-
- bits[end.first] |= end_mask;
}
}
- bool is_marked_p(Block *address)
+ bool marked_p(Block *address)
{
return bitmap_elt(marked,address);
}
set_bitmap_range(marked,address);
}
- bool is_allocated_p(Block *address)
- {
- return bitmap_elt(allocated,address);
- }
-
- void set_allocated_p(Block *address)
- {
- set_bitmap_range(allocated,address);
- }
-
- cell popcount1(u64 x)
- {
- cell accum = 0;
- while(x > 0)
- {
- accum += (x & 1);
- x >>= 1;
- }
- return accum;
- }
-
/* From http://chessprogramming.wikispaces.com/Population+Count */
cell popcount(u64 x)
{
- cell old = x;
u64 k1 = 0x5555555555555555ll;
u64 k2 = 0x3333333333333333ll;
u64 k4 = 0x0f0f0f0f0f0f0f0fll;
x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits
x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits
x = (x * kf) >> 56; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
-
- assert(x == popcount1(old));
+
return (cell)x;
}
/* The eventual destination of a block after compaction is just the number
- of marked blocks before it. */
+ of marked blocks before it. Live blocks must be marked on entry. */
void compute_forwarding()
{
cell accum = 0;
/* We have the popcount for every 64 entries; look up and compute the rest */
Block *forward_block(Block *original)
{
+#ifdef FACTOR_DEBUG
+ assert(marked_p(original));
+#endif
std::pair<cell,cell> pair = bitmap_deref(original);
cell approx_popcount = forwarding[pair.first];
u64 mask = ((u64)1 << pair.second) - 1;
cell new_line_number = approx_popcount + popcount(marked[pair.first] & mask);
- return line_block(new_line_number);
+ Block *new_block = line_block(new_line_number);
+#ifdef FACTOR_DEBUG
+ assert(new_block <= original);
+#endif
+ return new_block;
}
};
/* C++ headers */
#include <algorithm>
+#include <map>
#include <set>
#include <vector>
-
-#if __GNUC__ == 4
- #include <tr1/unordered_map>
-
- namespace factor
- {
- using std::tr1::unordered_map;
- }
-#elif __GNUC__ == 3
- #include <boost/unordered_map.hpp>
-
- namespace factor
- {
- using boost::unordered_map;
- }
-#else
- #error Factor requires GCC 3.x or later
-#endif
+#include <iostream>
/* Forward-declare this since it comes up in function prototypes */
namespace factor
#include "bignumint.hpp"
#include "bignum.hpp"
#include "code_block.hpp"
-#include "zone.hpp"
+#include "bump_allocator.hpp"
+#include "mark_bits.hpp"
+#include "free_list_allocator.hpp"
#include "write_barrier.hpp"
-#include "old_space.hpp"
+#include "object_start_map.hpp"
+#include "nursery_space.hpp"
#include "aging_space.hpp"
#include "tenured_space.hpp"
#include "data_heap.hpp"
#include "words.hpp"
#include "float_bits.hpp"
#include "io.hpp"
-#include "mark_bits.hpp"
-#include "heap.hpp"
#include "image.hpp"
#include "alien.hpp"
#include "code_heap.hpp"
#include "vm.hpp"
#include "tagged.hpp"
#include "local_roots.hpp"
+#include "slot_visitor.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "nursery_collector.hpp"
#include "aging_collector.hpp"
#include "to_tenured_collector.hpp"
+#include "code_block_visitor.hpp"
+#include "compaction.hpp"
#include "full_collector.hpp"
#include "callstack.hpp"
#include "generic_arrays.hpp"
collector.cheneys_algorithm();
update_code_heap_for_minor_gc(&code->points_to_nursery);
- nursery.here = nursery.start;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
}
struct nursery_policy {
factor_vm *parent;
- nursery_policy(factor_vm *parent_) : parent(parent_) {}
+ explicit nursery_policy(factor_vm *parent_) : parent(parent_) {}
- bool should_copy_p(object *untagged)
+ bool should_copy_p(object *obj)
{
- return parent->nursery.contains_p(untagged);
+ return parent->nursery.contains_p(obj);
}
+
+ void promoted_object(object *obj) {}
+
+ void visited_object(object *obj) {}
};
struct nursery_collector : copying_collector<aging_space,nursery_policy> {
- nursery_collector(factor_vm *parent_);
+ explicit nursery_collector(factor_vm *parent_);
};
}
--- /dev/null
+namespace factor
+{
+
+struct nursery_space : bump_allocator<object>
+{
+ explicit nursery_space(cell size, cell start) : bump_allocator<object>(size,start) {}
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+object_start_map::object_start_map(cell size_, cell start_) :
+ size(size_), start(start_)
+{
+ object_start_offsets = new card[addr_to_card(size_)];
+ object_start_offsets_end = object_start_offsets + addr_to_card(size_);
+ clear_object_start_offsets();
+}
+
+object_start_map::~object_start_map()
+{
+ delete[] object_start_offsets;
+}
+
+cell object_start_map::first_object_in_card(cell card_index)
+{
+ return object_start_offsets[card_index];
+}
+
+cell object_start_map::find_object_containing_card(cell card_index)
+{
+ if(card_index == 0)
+ return start;
+ else
+ {
+ card_index--;
+
+ while(first_object_in_card(card_index) == card_starts_inside_object)
+ {
+#ifdef FACTOR_DEBUG
+ /* First card should start with an object */
+ assert(card_index > 0);
+#endif
+ card_index--;
+ }
+
+ return start + (card_index << card_bits) + first_object_in_card(card_index);
+ }
+}
+
+/* we need to remember the first object allocated in the card */
+void object_start_map::record_object_start_offset(object *obj)
+{
+ cell idx = addr_to_card((cell)obj - start);
+ card obj_start = ((cell)obj & addr_card_mask);
+ object_start_offsets[idx] = std::min(object_start_offsets[idx],obj_start);
+}
+
+void object_start_map::clear_object_start_offsets()
+{
+ memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell card_starts_inside_object = 0xff;
+
+struct object_start_map {
+ cell size, start;
+ card *object_start_offsets;
+ card *object_start_offsets_end;
+
+ explicit object_start_map(cell size_, cell start_);
+ ~object_start_map();
+
+ cell first_object_in_card(cell card_index);
+ cell find_object_containing_card(cell card_index);
+ void record_object_start_offset(object *obj);
+ void clear_object_start_offsets();
+};
+
+}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-old_space::old_space(cell size_, cell start_) : zone(size_,start_)
-{
- object_start_offsets = new card[addr_to_card(size_)];
- object_start_offsets_end = object_start_offsets + addr_to_card(size_);
-}
-
-old_space::~old_space()
-{
- delete[] object_start_offsets;
-}
-
-cell old_space::first_object_in_card(cell card_index)
-{
- return object_start_offsets[card_index];
-}
-
-cell old_space::find_object_containing_card(cell card_index)
-{
- if(card_index == 0)
- return start;
- else
- {
- card_index--;
-
- while(first_object_in_card(card_index) == card_starts_inside_object)
- {
-#ifdef FACTOR_DEBUG
- /* First card should start with an object */
- assert(card_index > 0);
-#endif
- card_index--;
- }
-
- return start + (card_index << card_bits) + first_object_in_card(card_index);
- }
-}
-
-/* we need to remember the first object allocated in the card */
-void old_space::record_object_start_offset(object *obj)
-{
- cell idx = addr_to_card((cell)obj - start);
- if(object_start_offsets[idx] == card_starts_inside_object)
- object_start_offsets[idx] = ((cell)obj & addr_card_mask);
-}
-
-object *old_space::allot(cell size)
-{
- if(here + size > end) return NULL;
-
- object *obj = zone::allot(size);
- record_object_start_offset(obj);
- return obj;
-}
-
-void old_space::clear_object_start_offsets()
-{
- memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
-}
-
-cell old_space::next_object_after(factor_vm *parent, cell scan)
-{
- cell size = parent->untagged_object_size((object *)scan);
- if(scan + size < here)
- return scan + size;
- else
- return 0;
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell card_starts_inside_object = 0xff;
-
-struct old_space : zone {
- card *object_start_offsets;
- card *object_start_offsets_end;
-
- old_space(cell size_, cell start_);
- ~old_space();
-
- cell first_object_in_card(cell card_index);
- cell find_object_containing_card(cell card_index);
- void record_object_start_offset(object *obj);
- object *allot(cell size);
- void clear_object_start_offsets();
- cell next_object_after(factor_vm *parent, cell scan);
-};
-
-}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_esp;
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
}
}
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_esp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_eip)
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_rsp;
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
}
}
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rsp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rip)
}
const char *vm_executable_path();
const char *default_image_path();
+template<typename Type> Type align_stack_pointer(Type sp)
+{
+ return sp;
+}
+
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.arm_sp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-
void flush_icache(cell start, cell len);
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_sp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_pc)
+
}
{
#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1)
-
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_R1]
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_NIP])
}
#define X86_FXSR_MAGIC 0x0000
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
fpregs->mxcsr &= 0xffffffc0;
}
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[7])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[14])
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[15];
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
}
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[16])
}
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
return sp;
}
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
- return ((sp + 4) & ~15) - 4;
+ return (Type)((((cell)sp + 4) & ~15) - 4);
}
inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
- return ((sp + 8) & ~15) - 8;
+ return (Type)((((cell)sp + 8) & ~15) - 8);
}
inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
const char *vm_executable_path();
const char *default_image_path();
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
-
void c_to_factor_toplevel(cell quot);
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp)
+
}
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(false_object,(cell)localException));
- quot = userenv[COCOA_EXCEPTION_ENV];
+ quot = special_objects[OBJ_COCOA_EXCEPTION];
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{
/* No Cocoa exception handler was registered, so
namespace factor
{
-#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (_UC_MACHINE_SP((ucontext_t *)ucontext))
}
namespace factor
{
-#define ucontext_stack_pointer(uap) \
- ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.__gregs[_REG_URSP])
}
namespace factor
{
-inline static void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_esp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_esp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_eip)
}
namespace factor
{
-inline static void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_rsp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_rsp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_rip)
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[ESP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[ESP])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[EIP])
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[RSP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RSP])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RIP])
}
if(retval)
fatal_error("Segment deallocation failed",0);
}
-
-stack_frame *factor_vm::uap_stack_pointer(void *uap)
+
+void factor_vm::dispatch_signal(void *uap, void (handler)())
{
- /* There is a race condition here, but in practice a signal
- delivered during stack frame setup/teardown or while transitioning
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
{
- stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
- if(!ptr)
- critical_error("Invalid uap",(cell)uap);
- return ptr;
+ stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap);
+ assert(ptr);
+ signal_callstack_top = ptr;
}
else
- return NULL;
-}
+ signal_callstack_top = NULL;
-void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- signal_fault_addr = (cell)siginfo->si_addr;
- signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl;
+ UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap));
+ UAP_PROGRAM_COUNTER(uap) = (cell)handler;
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- tls_vm()->memory_signal_handler(signal,siginfo,uap);
-}
-
-void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- signal_number = signal;
- signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl;
+ factor_vm *vm = tls_vm();
+ vm->signal_fault_addr = (cell)siginfo->si_addr;
+ vm->dispatch_signal(uap,factor::memory_signal_handler_impl);
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- tls_vm()->misc_signal_handler(signal,siginfo,uap);
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
-void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- signal_number = signal;
- signal_callstack_top = uap_stack_pointer(uap);
- signal_fpu_status = fpu_status(uap_fpu_status(uap));
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
- UAP_PROGRAM_COUNTER(uap) =
- (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
- ? (cell)factor::misc_signal_handler_impl
- : (cell)factor::fp_signal_handler_impl;
-}
-void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- tls_vm()->fpe_signal_handler(signal, siginfo, uap);
+ vm->dispatch_signal(uap,
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? factor::misc_signal_handler_impl
+ : factor::fp_signal_handler_impl);
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define print_native_string(string) wprintf(L"%s",string)
-
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
{
gc_root<word> word(word_,this);
- jit jit(WORD_TYPE,word.value(),this);
- jit.emit_with(userenv[JIT_PROFILING],word.value());
+ jit jit(code_block_profiling,word.value(),this);
+ jit.emit_with(special_objects[JIT_PROFILING],word.value());
return jit.to_code_block();
}
tagged<word> word(array_nth(words.untagged(),i));
if(profiling)
word->counter = tag_fixnum(0);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
update_code_heap_words();
bool quotation_jit::primitive_call_p(cell i, cell length)
{
- return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_PRIMITIVE_WORD];
+ return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i, cell length)
{
return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == parent->userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == parent->special_objects[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_2DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_3DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i, cell length)
return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == parent->userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == parent->special_objects[MEGA_LOOKUP_WORD];
}
bool quotation_jit::declare_p(cell i, cell length)
{
return (i + 2) <= length
- && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DECLARE_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(!parent->to_boolean(parent->untag<word>(obj)->subprimitive))
+ if(!parent->to_boolean(untag<word>(obj)->subprimitive))
return true;
break;
case QUOTATION_TYPE:
{
gc_root<quotation> quot(quot_,parent);
- array *elements =
parent->untag<array>(quot->array);
+ array *elements = untag<array>(quot->array);
/* If the quotation consists of a single word, compile a direct call
to the word. */
set_position(0);
if(stack_frame)
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
if(parent->to_boolean(obj.as<word>()->subprimitive))
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == parent->userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == parent->special_objects[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
else
- emit(parent->userenv[JIT_EXECUTE_CALL]);
+ emit(parent->special_objects[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == parent->userenv[PIC_MISS_WORD]
- || obj.value() == parent->userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == parent->special_objects[PIC_MISS_WORD]
+ || obj.value() == parent->special_objects[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
{
literal(tag_fixnum(0));
literal(obj.value());
- emit(parent->userenv[JIT_PRIMITIVE]);
+ emit(parent->special_objects[JIT_PRIMITIVE]);
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i,length))
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
emit_quot(array_nth(elements.untagged(),i));
emit_quot(array_nth(elements.untagged(),i + 1));
- emit(parent->userenv[JIT_IF]);
+ emit(parent->special_objects[JIT_IF]);
i += 2;
}
else if(fast_dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_DIP]);
+ emit(parent->special_objects[JIT_DIP]);
i++;
}
/* 2dip */
else if(fast_2dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_2DIP]);
+ emit(parent->special_objects[JIT_2DIP]);
i++;
}
/* 3dip */
else if(fast_3dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_3DIP]);
+ emit(parent->special_objects[JIT_3DIP]);
i++;
}
else
set_position(length);
if(stack_frame)
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_RETURN]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_RETURN]);
}
}
void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
- assert(code->type() == QUOTATION_TYPE);
quot->code = code;
quot->xt = code->xt();
}
{
gc_root<word> word(array_nth(words.untagged(),i),this);
- if(!word->code || !word_optimized_p(word.untagged()))
+ if(!word->code || !word->code->optimized_p())
jit_compile_word(word.value(),word->def,false);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
bool compiling, relocate;
explicit quotation_jit(cell quot, bool compiling_, bool relocate_, factor_vm *vm)
- : jit(QUOTATION_TYPE,quot,vm),
+ : jit(code_block_unoptimized,quot,vm),
elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
relocate(relocate_){};
void factor_vm::primitive_getenv()
{
fixnum e = untag_fixnum(dpeek());
- drepl(userenv[e]);
+ drepl(special_objects[e]);
}
void factor_vm::primitive_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
- userenv[e] = value;
+ special_objects[e] = value;
}
void factor_vm::primitive_exit()
namespace factor
{
-#define USER_ENV 70
+static const cell special_object_count = 70;
enum special_object {
- NAMESTACK_ENV, /* used by library only */
- CATCHSTACK_ENV, /* used by library only, per-callback */
+ OBJ_NAMESTACK, /* used by library only */
+ OBJ_CATCHSTACK, /* used by library only, per-callback */
- CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
- WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
- CALLCC_1_ENV, /* used to pass the value in callcc1 */
+ OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
+ OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_CALLCC_1, /* used to pass the value in callcc1 */
- BREAK_ENV = 5, /* quotation called by throw primitive */
- ERROR_ENV, /* a marker consed onto kernel errors */
+ OBJ_BREAK = 5, /* quotation called by throw primitive */
+ OBJ_ERROR, /* a marker consed onto kernel errors */
- CELL_SIZE_ENV = 7, /* sizeof(cell) */
- CPU_ENV, /* CPU architecture */
- OS_ENV, /* operating system name */
+ OBJ_CELL_SIZE = 7, /* sizeof(cell) */
+ OBJ_CPU, /* CPU architecture */
+ OBJ_OS, /* operating system name */
- ARGS_ENV = 10, /* command line arguments */
- STDIN_ENV, /* stdin FILE* handle */
- STDOUT_ENV, /* stdout FILE* handle */
+ OBJ_ARGS = 10, /* command line arguments */
+ OBJ_STDIN, /* stdin FILE* handle */
+ OBJ_STDOUT, /* stdout FILE* handle */
- IMAGE_ENV = 13, /* image path name */
- EXECUTABLE_ENV, /* runtime executable path name */
+ OBJ_IMAGE = 13, /* image path name */
+ OBJ_EXECUTABLE, /* runtime executable path name */
- EMBEDDED_ENV = 15, /* are we embedded in another app? */
- EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ OBJ_EMBEDDED = 15, /* are we embedded in another app? */
+ OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
- COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
+ OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
- BOOT_ENV = 20, /* boot quotation */
- GLOBAL_ENV, /* global namespace */
+ OBJ_BOOT = 20, /* boot quotation */
+ OBJ_GLOBAL, /* global namespace */
/* Quotation compilation in quotations.c */
JIT_PROLOG = 23,
MEGA_LOOKUP_WORD,
MEGA_MISS_WORD,
- UNDEFINED_ENV = 60, /* default quotation for undefined words */
+ OBJ_UNDEFINED = 60, /* default quotation for undefined words */
- STDERR_ENV = 61, /* stderr FILE* handle */
+ OBJ_STDERR = 61, /* stderr FILE* handle */
- STAGE2_ENV = 62, /* have we bootstrapped? */
+ OBJ_STAGE2 = 62, /* have we bootstrapped? */
- CURRENT_THREAD_ENV = 63,
+ OBJ_CURRENT_THREAD = 63,
- THREADS_ENV = 64,
- RUN_QUEUE_ENV = 65,
- SLEEP_QUEUE_ENV = 66,
+ OBJ_THREADS = 64,
+ OBJ_RUN_QUEUE = 65,
+ OBJ_SLEEP_QUEUE = 66,
};
-#define FIRST_SAVE_ENV BOOT_ENV
-#define LAST_SAVE_ENV STAGE2_ENV
+#define OBJ_FIRST_SAVE OBJ_BOOT
+#define OBJ_LAST_SAVE OBJ_STAGE2
inline static bool save_env_p(cell i)
{
- return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV);
+ return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
}
}
--- /dev/null
+namespace factor
+{
+
+template<typename Visitor> struct slot_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit slot_visitor<Visitor>(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void visit_handle(cell *handle)
+ {
+ cell pointer = *handle;
+
+ if(immediate_p(pointer)) return;
+
+ object *untagged = untag<object>(pointer);
+ untagged = visitor.visit_object(untagged);
+ *handle = RETAG(untagged,TAG(pointer));
+ }
+
+ void visit_slots(object *ptr, cell payload_start)
+ {
+ cell *slot = (cell *)ptr;
+ cell *end = (cell *)((cell)ptr + payload_start);
+
+ if(slot != end)
+ {
+ slot++;
+ for(; slot < end; slot++) visit_handle(slot);
+ }
+ }
+
+ void visit_slots(object *ptr)
+ {
+ visit_slots(ptr,ptr->binary_payload_start());
+ }
+
+ void visit_stack_elements(segment *region, cell *top)
+ {
+ for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
+ visit_handle(ptr);
+ }
+
+ void visit_registered_locals()
+ {
+ std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
+ std::vector<cell>::const_iterator end = parent->gc_locals.end();
+
+ for(; iter < end; iter++)
+ visit_handle((cell *)(*iter));
+ }
+
+ void visit_registered_bignums()
+ {
+ std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
+ std::vector<cell>::const_iterator end = parent->gc_bignums.end();
+
+ for(; iter < end; iter++)
+ {
+ cell *handle = (cell *)(*iter);
+
+ if(*handle)
+ *handle = (cell)visitor.visit_object(*(object **)handle);
+ }
+ }
+
+ void visit_roots()
+ {
+ visit_handle(&parent->true_object);
+ visit_handle(&parent->bignum_zero);
+ visit_handle(&parent->bignum_pos_one);
+ visit_handle(&parent->bignum_neg_one);
+
+ visit_registered_locals();
+ visit_registered_bignums();
+
+ for(cell i = 0; i < special_object_count; i++)
+ visit_handle(&parent->special_objects[i]);
+ }
+
+ void visit_contexts()
+ {
+ context *ctx = parent->ctx;
+
+ while(ctx)
+ {
+ visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
+ visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+
+ visit_handle(&ctx->catchstack_save);
+ visit_handle(&ctx->current_callback_save);
+
+ ctx = ctx->next;
+ }
+ }
+
+ void visit_literal_references(code_block *compiled)
+ {
+ visit_handle(&compiled->owner);
+ visit_handle(&compiled->literals);
+ visit_handle(&compiled->relocation);
+ }
+};
+
+}
namespace factor
{
-cell factor_vm::string_nth(string* str, cell index)
+cell string::nth(cell index) const
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
corresponding aux vector entry is negated, so that we can
XOR the two components together and get the original code point
back. */
- cell lo_bits = str->data()[index];
+ cell lo_bits = data()[index];
if((lo_bits & 0x80) == 0)
return lo_bits;
else
{
- byte_array *aux = untag<byte_array>(str->aux);
+ byte_array *aux = untag<byte_array>(this->aux);
cell hi_bits = aux->data<u16>()[index];
return (hi_bits << 7) ^ lo_bits;
}
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
- aux = allot_array_internal<byte_array>(untag_fixnum(str->length) * sizeof(u16));
+ aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
str->aux = tag<byte_array>(aux);
write_barrier(&str->aux);
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
- dpush(tag_fixnum(string_nth(str,index)));
+ dpush(tag_fixnum(str->nth(index)));
}
void factor_vm::primitive_set_string_nth_fast()
namespace factor
{
-inline static cell string_capacity(string *str)
+inline static cell string_capacity(const string *str)
{
return untag_fixnum(str->length);
}
{
cell value_;
- cell value() const { return value_; }
- Type *untagged() const { return (Type *)(UNTAG(value_)); }
-
cell type() const {
cell tag = TAG(value_);
if(tag == OBJECT_TYPE)
- return untagged()->h.hi_tag();
+ return ((object *)UNTAG(value_))->h.hi_tag();
else
return tag;
}
- bool type_p(cell type_) const { return type() == type_; }
+ bool type_p(cell type_) const
+ {
+ return type() == type_;
+ }
- Type *untag_check(factor_vm *parent) const {
- if(Type::type_number != TYPE_COUNT && !type_p(Type::type_number))
- parent->type_error(Type::type_number,value_);
- return untagged();
+ bool type_p() const
+ {
+ if(Type::type_number == TYPE_COUNT)
+ return true;
+ else
+ return type_p(Type::type_number);
}
- explicit tagged(cell tagged) : value_(tagged) {
+ cell value() const {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return value_;
}
-
- explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {
+ Type *untagged() const {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return (Type *)(UNTAG(value_));
}
+ Type *untag_check(factor_vm *parent) const {
+ if(!type_p())
+ parent->type_error(Type::type_number,value_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {}
+ explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {}
+
Type *operator->() const { return untagged(); }
cell *operator&() const { return &value_; }
return tagged<Type>(value).untag_check(this);
}
-template<typename Type> Type *factor_vm::untag(cell value)
+template<typename Type> Type *untag(cell value)
{
return tagged<Type>(value).untagged();
}
namespace factor
{
-struct tenured_space : old_space {
- tenured_space(cell size, cell start) : old_space(size,start) {}
+struct tenured_space : free_list_allocator<object> {
+ object_start_map starts;
+ std::vector<object *> mark_stack;
+
+ explicit tenured_space(cell size, cell start) :
+ free_list_allocator<object>(size,start), starts(size,start) {}
+
+ object *allot(cell size)
+ {
+ object *obj = free_list_allocator<object>::allot(size);
+ if(obj)
+ {
+ starts.record_object_start_offset(obj);
+ return obj;
+ }
+ else
+ return NULL;
+ }
+
+ object *first_allocated_block_after(object *block)
+ {
+ while(block != this->last_block() && block->free_p())
+ {
+ free_heap_block *free_block = (free_heap_block *)block;
+ block = (object *)((cell)free_block + free_block->size());
+ }
+
+ if(block == this->last_block())
+ return NULL;
+ else
+ return block;
+ }
+
+ cell first_object()
+ {
+ return (cell)first_allocated_block_after(this->first_block());
+ }
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((object *)scan)->size();
+ object *next = (object *)(scan + size);
+ return (cell)first_allocated_block_after(next);
+ }
+
+ void clear_mark_bits()
+ {
+ state.clear_mark_bits();
+ }
+
+ void clear_mark_stack()
+ {
+ mark_stack.clear();
+ }
+
+ bool marked_p(object *obj)
+ {
+ return this->state.marked_p(obj);
+ }
+
+ void mark_and_push(object *obj)
+ {
+ this->state.set_marked_p(obj);
+ this->mark_stack.push_back(obj);
+ }
};
}
{
to_tenured_collector::to_tenured_collector(factor_vm *myvm_) :
- copying_collector<tenured_space,to_tenured_policy>(
+ collector<tenured_space,to_tenured_policy>(
myvm_,
&myvm_->gc_stats.aging_stats,
myvm_->data->tenured,
to_tenured_policy(myvm_)) {}
+void to_tenured_collector::tenure_reachable_objects()
+{
+ std::vector<object *> *mark_stack = &this->target->mark_stack;
+ while(!mark_stack->empty())
+ {
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ this->trace_slots(obj);
+ }
+}
+
void factor_vm::collect_to_tenured()
{
/* Copy live objects from aging space to tenured space. */
to_tenured_collector collector(this);
+ data->tenured->clear_mark_stack();
+
collector.trace_roots();
collector.trace_contexts();
collector.trace_cards(data->tenured,
card_points_to_aging,
- dummy_unmarker());
+ simple_unmarker(card_mark_mask));
collector.trace_code_heap_roots(&code->points_to_aging);
- collector.cheneys_algorithm();
+ collector.tenure_reachable_objects();
update_code_heap_for_minor_gc(&code->points_to_aging);
- nursery.here = nursery.start;
- reset_generation(data->aging);
- code->points_to_nursery.clear();
- code->points_to_aging.clear();
+ data->reset_generation(&nursery);
+ data->reset_generation(data->aging);
+ code->clear_remembered_set();
}
}
struct to_tenured_policy {
factor_vm *myvm;
- zone *tenured;
+ tenured_space *tenured;
- to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
+ explicit to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_stack.push_back(obj);
+ }
+
+ void visited_object(object *obj) {}
};
-struct to_tenured_collector : copying_collector<tenured_space,to_tenured_policy> {
- to_tenured_collector(factor_vm *myvm_);
+struct to_tenured_collector : collector<tenured_space,to_tenured_policy> {
+ explicit to_tenured_collector(factor_vm *myvm_);
+ void tenure_reachable_objects();
};
}
namespace factor
{
-inline static cell tuple_size(tuple_layout *layout)
+inline static cell tuple_size(const tuple_layout *layout)
{
cell size = untag_fixnum(layout->size);
return sizeof(tuple) + size * sizeof(cell);
return ptr;
}
-/* We don't use printf directly, because format directives are not portable.
-Instead we define the common cases here. */
-void nl()
-{
- fputs("\n",stdout);
-}
-
-void print_string(const char *str)
-{
- fputs(str,stdout);
-}
-
-void print_cell(cell x)
-{
- printf(CELL_FORMAT,x);
-}
-
-void print_cell_hex(cell x)
-{
- printf(CELL_HEX_FORMAT,x);
-}
-
-void print_cell_hex_pad(cell x)
-{
- printf(CELL_HEX_PAD_FORMAT,x);
-}
-
-void print_fixnum(fixnum x)
-{
- printf(FIXNUM_FORMAT,x);
-}
-
cell read_cell_hex()
{
cell cell;
namespace factor
{
vm_char *safe_strdup(const vm_char *str);
- void print_string(const char *str);
- void nl();
- void print_cell(cell x);
- void print_cell_hex(cell x);
void print_cell_hex_pad(cell x);
- void print_fixnum(fixnum x);
cell read_cell_hex();
}
factor_vm::factor_vm() :\r
nursery(0,0),\r
profiling_p(false),\r
- secure_gc(false),\r
gc_off(false),\r
current_gc(NULL),\r
fep_disabled(false),\r
context *ctx;
/* New objects are allocated here */
- zone nursery;
+ nursery_space nursery;
/* Add this to a shifted address to compute write barrier offsets */
cell cards_offset;
cell decks_offset;
/* TAGGED user environment data; see getenv/setenv prims */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
cell ds_size, rs_size;
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
- /* Zeroes out deallocated memory; set by the -securegc command line argument */
- bool secure_gc;
-
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
cell heap_scan_ptr;
/* GC is off during heap walking */
bool gc_off;
+ /* GC logging */
+ bool verbosegc;
+
/* Data heap */
data_heap *data;
//data heap
void init_card_decks();
- void clear_cards(old_space *gen);
- void clear_decks(old_space *gen);
- void reset_generation(old_space *gen);
void set_data_heap(data_heap *data_);
- void init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_);
- cell untagged_object_size(object *pointer);
- cell unaligned_object_size(object *pointer);
+ void init_data_heap(cell young_size, cell aging_size, cell tenured_size);
void primitive_size();
- cell binary_payload_start(object *pointer);
void primitive_data_room();
void begin_scan();
void end_scan();
void collect_nursery();
void collect_aging();
void collect_to_tenured();
- void collect_full_impl(bool trace_contexts_p);
- void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
- void collect_full(bool trace_contexts_p, bool compact_code_heap_p);
+ void collect_mark_impl(bool trace_contexts_p);
+ void collect_sweep_impl();
+ void collect_compact_impl(bool trace_contexts_p);
+ void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
void record_gc_stats(generation_statistics *stats);
- void gc(gc_op op, cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
+ void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
#endif
}
- inline void check_tagged_pointer(cell tagged)
- {
- #ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
- #endif
- }
-
// generic arrays
- template<typename Array> Array *allot_array_internal(cell capacity);
+ template<typename Array> Array *allot_uninitialized_array(cell capacity);
template<typename Array> bool reallot_array_in_place_p(Array *array, cell capacity);
template<typename Array> Array *reallot_array(Array *array_, cell capacity);
void print_callstack();
void dump_cell(cell x);
void dump_memory(cell from, cell to);
- void dump_zone(const char *name, zone *z);
+ template<typename Generation> void dump_generation(const char *name, Generation *gen);
void dump_generations();
void dump_objects(cell type);
void find_data_references_step(cell *scan);
inline void set_array_nth(array *array, cell slot, cell value);
//strings
- cell string_nth(string* str, cell index);
+ cell string_nth(const string *str, cell index);
void set_string_nth_fast(string *str, cell index, cell ch);
void set_string_nth_slow(string *str_, cell index, cell ch);
void set_string_nth(string *str, cell index, cell ch);
word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word();
void primitive_word_xt();
- void update_word_xt(cell w_);
+ void update_word_xt(word *w_);
void primitive_optimized_p();
void primitive_wrapper();
inline double untag_float_check(cell tagged);
inline fixnum float_to_fixnum(cell tagged);
inline double fixnum_to_float(cell tagged);
+
+ // tagged
template<typename Type> Type *untag_check(cell value);
- template<typename Type> Type *untag(cell value);
//io
void init_c_io();
void update_literal_references(code_block *compiled);
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
void update_word_references(code_block *compiled);
- void update_code_block_for_full_gc(code_block *compiled);
+ void update_code_block_words_and_literals(code_block *compiled);
void check_code_address(cell address);
void relocate_code_block(code_block *compiled);
void fixup_labels(array *labels, code_block *compiled);
- code_block *allot_code_block(cell size, cell type);
- code_block *add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
+ code_block *allot_code_block(cell size, code_block_type type);
+ code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
//code heap
inline void check_code_pointer(cell ptr)
bool in_code_heap_p(cell ptr);
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
+ void update_code_heap_words_and_literals();
+ void relocate_code_heap();
void primitive_modify_code_heap();
void primitive_code_room();
- void forward_object_xts();
- void forward_context_xts();
- void forward_callback_xts();
- void compact_code_heap(bool trace_contexts_p);
void primitive_strip_stack_traces();
/* Apply a function to every code block */
template<typename Iterator> void iterate_code_heap(Iterator &iter)
{
- heap_block *scan = code->first_block();
- heap_block *end = code->last_block();
-
- while(scan != end)
- {
- if(scan->type() != FREE_BLOCK_TYPE)
- iter((code_block *)scan);
- scan = scan->next();
- }
+ code->allocator->iterate(iter);
}
//callbacks
void primitive_callstack();
void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
- cell frame_type(stack_frame *frame);
+ code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
template<typename Iterator> void do_slots(cell obj, Iterator &iter)
{
cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
+ cell payload_start = ((object *)obj)->binary_payload_start();
cell end = obj + payload_start;
scan += sizeof(cell);
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
bool windows_stat(vm_char *path);
- #if defined(WINNT)
+ #if defined(WINNT)
void open_console();
LONG exception_handler(PEXCEPTION_POINTERS pe);
- // next method here:
- #endif
+ #endif
#else // UNIX
- void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- stack_frame *uap_stack_pointer(void *uap);
-
+ void dispatch_signal(void *uap, void (handler)());
#endif
#ifdef __APPLE__
};
-extern unordered_map<THREADHANDLE, factor_vm *> thread_vms;
+extern std::map<THREADHANDLE, factor_vm *> thread_vms;
}
new_word->hashcode = hashcode_;
new_word->vocabulary = vocab.value();
new_word->name = name.value();
- new_word->def = userenv[UNDEFINED_ENV];
+ new_word->def = special_objects[OBJ_UNDEFINED];
new_word->props = false_object;
new_word->counter = tag_fixnum(0);
new_word->pic_def = false_object;
new_word->code = NULL;
jit_compile_word(new_word.value(),new_word->def,true);
- update_word_xt(new_word.value());
+ update_word_xt(new_word.untagged());
if(profiling_p)
relocate_code_block(new_word->profiling);
}
/* Allocates memory */
-void factor_vm::update_word_xt(cell w_)
+void factor_vm::update_word_xt(word *w_)
{
gc_root<word> w(w_,this);
void factor_vm::primitive_optimized_p()
{
- drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
+ word *w = untag_check<word>(dpeek());
+ drepl(tag_boolean(w->code->optimized_p()));
}
void factor_vm::primitive_wrapper()
namespace factor
{
-inline bool word_optimized_p(word *word)
-{
- return word->code->type() == WORD_TYPE;
-}
-
}
+++ /dev/null
-namespace factor
-{
-
-struct zone {
- /* offset of 'here' and 'end' is hardcoded in compiler backends */
- cell here;
- cell start;
- cell end;
- cell size;
-
- zone(cell size_, cell start_) : here(0), start(start_), end(start_ + size_), size(size_) {}
-
- inline bool contains_p(object *pointer)
- {
- return ((cell)pointer - start) < size;
- }
-
- inline object *allot(cell size)
- {
- cell h = here;
- here = h + align8(size);
- return (object *)h;
- }
-};
-
-}
projects / factor.git / commitdiff