From: Guillaume Nargeot Date: Thu, 22 Oct 2009 09:39:12 +0000 (+0900) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.97~5102^2~127^2~2 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=10414e01837f2769ab8e0755b4782724a7d4ace4;hp=2d6e47d7106c2d5c11583f4caf68727dc534cbed Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 4ccd0e7488..6a5644cceb 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -1,18 +1,19 @@ ! 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 diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor index a798eb15ba..e1ec43f1dc 100644 --- a/basis/cocoa/callbacks/callbacks.factor +++ b/basis/cocoa/callbacks/callbacks.factor @@ -16,11 +16,11 @@ CLASS: { { +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 diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index c657a5e6e8..892d5ea38d 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,6 +1,7 @@ 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: { @@ -8,8 +9,8 @@ CLASS: { { +name+ "Foo" } } { "foo:" - "void" - { "id" "SEL" "NSRect" } + void + { id SEL NSRect } [ gc "x" set 2drop ] } ; @@ -30,8 +31,8 @@ CLASS: { { +name+ "Bar" } } { "bar" - "NSRect" - { "id" "SEL" } + NSRect + { id SEL } [ 2drop test-foo "x" get ] } ; @@ -52,13 +53,13 @@ CLASS: { { +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 ] } ; diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index c0d8939a7a..fce7adc04a 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -2,10 +2,12 @@ ! 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* @@ -98,75 +100,84 @@ class-init-hooks [ H{ } clone ] initialize 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 ; @@ -177,9 +188,9 @@ 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 ; diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index dd2b029266..6a63b719df 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -9,10 +9,10 @@ IN: compiler.alien : 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 ; @@ -20,8 +20,7 @@ IN: compiler.alien : 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 + diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index b5510c7142..1f01bc438b 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -27,7 +27,9 @@ M: ##call compute-stack-frame* 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* diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index d303cc597f..a4651b87b5 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math 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. @@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests [ [ 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 ] @@ -213,4 +214,4 @@ IN: compiler.cfg.builder.tests ] 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 diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 74586c6eeb..11aae28bf3 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; 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 ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 3b6674efee..2af810ba49 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -163,8 +163,8 @@ IN: compiler.cfg.intrinsics { 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 ] } diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 73f880a102..9d17ddd0f8 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats 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 -- ) @@ -155,28 +155,79 @@ MACRO: if-literals-match ( 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 ) { { @@ -265,3 +316,17 @@ MACRO: if-literals-match ( quots -- ) ] } 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 ; + diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 8a86c984fe..e1088a80ef 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,8 +1,9 @@ ! 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 @@ -22,11 +23,17 @@ 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 ; @@ -61,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots 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 ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 4b071cb43c..3cfade23e1 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -9,7 +9,8 @@ TUPLE: stack-frame { 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 ) @@ -35,7 +36,9 @@ TUPLE: stack-frame : 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 diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 3842942a3b..28c6741bc1 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -13,11 +13,18 @@ compiler.cfg.value-numbering.graph 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 @@ -174,8 +181,8 @@ M: ##compare-imm-branch rewrite 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 ; @@ -205,8 +212,8 @@ M: ##compare-branch rewrite 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 ; @@ -264,6 +271,19 @@ M: ##neg rewrite 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 ) [ { @@ -273,7 +293,7 @@ M: ##not rewrite [ ] } 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 { @@ -283,7 +303,7 @@ 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 @@ -358,16 +378,20 @@ M: ##sar-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 @@ -491,3 +515,48 @@ M: ##scalar>vector rewrite 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 ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 733b8cc22a..55ff39e9d2 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1281,6 +1281,128 @@ cell 8 = [ } 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 ) [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 31918658c4..e8f3ca7d64 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -333,35 +333,29 @@ M: reg-class reg-class-full? [ alloc-stack-param ] [ alloc-fastcall-param ] if [ param-reg ] dip ; -: (flatten-int-type) ( size -- seq ) - cell /i "void*" c-type ; +: (flatten-int-type) ( type -- seq ) + stack-size cell align cell /i void* c-type ; 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 % ] 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 ; @@ -378,10 +372,17 @@ M: long-long-type flatten-value-type ( type -- types ) [ '[ 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 @@ -413,7 +414,7 @@ M: long-long-type flatten-value-type ( type -- types ) ] 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 ] diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1bf7a00c75..ef8cb5f0a4 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ; [ [ 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 @@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ; [ -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 @@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ; 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 ] [ @@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, ! 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 @@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ! 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* @@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ] unit-test : callback-4 ( -- callback ) - "void" { } "cdecl" [ "Hello world" write ] alien-callback + void { } "cdecl" [ "Hello world" write ] alien-callback gc ; [ "Hello world" ] [ @@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ] 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 ; @@ -440,13 +440,13 @@ STRUCT: double-rect } 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 ] @@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; ] unit-test : callback-10 ( -- callback ) - "test_struct_14" { "double" "double" } "cdecl" + test_struct_14 { double double } "cdecl" [ test_struct_14 swap >>x2 @@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double 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 @@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; ] unit-test : callback-11 ( -- callback ) - "test-struct-12" { "int" "double" } "cdecl" + test-struct-12 { int double } "cdecl" [ test-struct-12 swap >>x @@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double 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 @@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; [ 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 swap >>y @@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float 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 @@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; [ 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 swap >>a @@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int 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 diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 141fc24309..18f3a618f6 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -270,8 +270,8 @@ TUPLE: id obj ; { 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 ; @@ -475,4 +475,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read- [ 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 diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 24114e0ccb..75cfc1d67f 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -87,14 +87,17 @@ IN: compiler.tests.intrinsics [ 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 diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index e508b55b8d..14c470d63f 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -98,7 +98,7 @@ IN: compiler.tests.low-level-ir 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 diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 53b2109bbb..9030914e34 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -340,18 +340,3 @@ SYMBOL: value-infos 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 ; diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 6f5484fb77..24ac24bb6a 100755 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -36,8 +36,8 @@ STRUCT: FSEventStreamContext { 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 diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 7b454266f2..0b61274b22 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -115,7 +115,7 @@ PRIVATE> [ 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 ( -- ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d5b84b7002..c411d97558 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -440,9 +440,13 @@ M: reg-class param-reg param-regs nth ; 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 -- ? ) @@ -459,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? ) ! 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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 48eaf54f46..517aa7587d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- ) 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 loc>operand LWZ ; M: ppc %unbox ( n rep func -- ) ! Value must be in r3 @@ -681,7 +679,9 @@ M: ppc %callback-value ( ctype -- ) ! 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?>> ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 3ce1374491..cff5c561c8 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ; 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 MOV building get pop @@ -57,12 +62,12 @@ M:: x86.32 %dispatch ( src temp -- ) 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 @@ -72,44 +77,34 @@ M: x86.32 return-struct-in-registers? ( 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 ; @@ -118,16 +113,14 @@ 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 @@ -136,56 +129,39 @@ M:: x86.32 %box ( n rep func -- ) 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. @@ -194,37 +170,33 @@ M: x86.32 %unbox ( n rep func -- ) #! 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. @@ -236,63 +208,46 @@ M: x86 %unbox-small-struct ( size -- ) 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 ; @@ -357,17 +312,11 @@ M: x86.32 %callback-return ( n -- ) } 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 ; @@ -375,10 +324,13 @@ M: x86.32 dummy-int-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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c34530c307..cbc5c4d7e5 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame 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 } } @@ -17,9 +33,13 @@ M: x86.64 machine-registers } } } ; -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 ; @@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- ) [ 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 { @@ -84,10 +88,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ; 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 @@ -217,9 +219,7 @@ M: x86.64 %alien-callback ( quot -- ) "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 diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index b3d184bc97..2fb32ce733 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -12,7 +12,7 @@ M: int-regs param-regs 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 diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index bbe943e06b..3ecd56bdd1 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ; 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? ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 60d47b78ff..d19a9b0c8c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ; 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 ; @@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n ) 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 @@ -879,12 +888,12 @@ M: x86 %compare-vector ( dst src1 src2 rep cc -- ) { { 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 ; @@ -1089,7 +1098,7 @@ M: x86 %min-vector ( dst src1 src2 rep -- ) 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 ; @@ -1109,7 +1118,7 @@ M: x86 %max-vector ( dst src1 src2 rep -- ) 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 ; @@ -1337,7 +1346,10 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- ) 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 ) diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 61394391a0..c180df9bf5 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 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 @@ -120,8 +120,8 @@ FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; 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 ) ; @@ -134,8 +134,8 @@ FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; 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 ) ; diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor old mode 100644 new mode 100755 index 1f4b8fb0ac..319f100e16 --- a/basis/debugger/windows/windows.factor +++ b/basis/debugger/windows/windows.factor @@ -1,6 +1,42 @@ ! 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 ; diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor index c4eab2d6ab..65f13261a9 100644 --- a/basis/eval/eval.factor +++ b/basis/eval/eval.factor @@ -1,7 +1,8 @@ ! 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 ) @@ -19,7 +20,7 @@ SYNTAX: eval( \ eval parse-call( ; [ "quiet" on parser-notes off - '[ _ (( -- )) (eval) ] try + '[ _ (( -- )) (eval) ] [ print-error ] recover ] with-string-writer ; : eval>string ( str -- output ) diff --git a/basis/help/handbook/handbook-tests.factor b/basis/help/handbook/handbook-tests.factor index 709d56c5d6..157d4c76e0 100644 --- a/basis/help/handbook/handbook-tests.factor +++ b/basis/help/handbook/handbook-tests.factor @@ -4,5 +4,4 @@ IN: help.handbook.tests [ ] [ "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 diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 4dd3481f65..afb88bbd3c 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index" 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 ] } @@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook" "article-index" "primitive-index" "error-index" - "type-index" "class-index" } { $heading "Explore the code base" } diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 2a5a9c640d..ee22782fdc 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -33,7 +33,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program" $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 diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index f14dd3290c..fa12aaa320 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -6,8 +6,8 @@ images.loader images.normalization io io.binary 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 diff --git a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor index 84a609643a..276949a99f 100644 --- a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor @@ -3,13 +3,14 @@ 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 diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index fe16e08467..caa2f95dae 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -68,8 +68,7 @@ ARTICLE: "io.mmap.arrays" "Working with memory-mapped data" "The " { $link } " 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 } "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." ; @@ -101,10 +100,10 @@ ARTICLE: "io.mmap" "Memory-mapped files" { $subsections } "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" diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index 94f8c77883..967009243e 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -1,7 +1,8 @@ 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 diff --git a/basis/math/vectors/conversion/conversion-docs.factor b/basis/math/vectors/conversion/conversion-docs.factor new file mode 100644 index 0000000000..9fe5ac4c17 --- /dev/null +++ b/basis/math/vectors/conversion/conversion-docs.factor @@ -0,0 +1,75 @@ +! (c)2009 Joe Groff bsd license +USING: classes help.markup help.syntax kernel quotations ; +IN: math.vectors.conversion + +HELP: bad-vconvert +{ $values + { "from-type" "a SIMD type" } { "to-type" "a SIMD type" } +} +{ $description "This error is thrown when " { $link vconvert } " is given two SIMD types it cannot directly convert." } ; + +HELP: bad-vconvert-input +{ $values + { "value" object } { "expected-type" class } +} +{ $description "This error is thrown when an input to " { $link vconvert } " does not match the expected " { $snippet "from-type" } "." } ; + +{ bad-vconvert bad-vconvert-input } related-words + +HELP: vconvert +{ $values + { "from-type" "a SIMD type" } { "to-type" "a SIMD type" } +} +{ $description "Converts SIMD vectors of " { $snippet "from-type" } " to " { $snippet "to-type" } ". The number of inputs and outputs depends on the relationship of the two types:" +{ $list +{ "If " { $snippet "to-type" } " is a floating-point vector type with the same byte length and element count as the integer vector type " { $snippet "from-type" } " (for example, from " { $snippet "int-8" } " to " { $snippet "float-8" } " or from " { $snippet "longlong-2" } " to " { $snippet "double-2" } "), " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and converts its elements to floating-point, outputting one vector of " { $snippet "to-type" } "." } +{ "Likewise, if " { $snippet "to-type" } " is an integer vector type with the same byte length and element count as the floating-point vector type " { $snippet "from-type" } ", " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and truncates its elements to integers, outputting one vector of " { $snippet "to-type" } "." } +{ "If " { $snippet "to-type" } " is a vector type with the same byte length as and twice the element count of the vector type " { $snippet "from-type" } " (for example, from " { $snippet "int-4" } " to " { $snippet "ushort-8" } ", from " { $snippet "double-2" } " to " { $snippet "float-4" } ", or from " { $snippet "short-8" } " to " { $snippet "char-16" } "), " { $snippet "vconvert" } " takes two vectors of " { $snippet "from-type" } " and packs them into one vector of " { $snippet "to-type" } ", saturating values too large or small to be representable as elements of " { $snippet "to-type" } "." } +{ "If " { $snippet "to-type" } " is a vector type with the same byte length as and half the element count of the vector type " { $snippet "from-type" } " (for example, from " { $snippet "ushort-8" } " to " { $snippet "int-4" } ", from " { $snippet "float-4" } " to " { $snippet "double-2" } ", or from " { $snippet "char-16" } " to " { $snippet "short-8" } "), " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and unpacks it into two vectors of " { $snippet "to-type" } "." } +} +{ $snippet "from-type" } " and " { $snippet "to-type" } " must adhere to the following restrictions; a " { $link bad-vconvert } " error will be thrown otherwise:" +{ $list +{ { $snippet "from-type" } " and " { $snippet "to-type" } " must have the same byte length. You cannot currently convert between 128- and 256-bit vector types." } +{ "For conversions between floating-point and integer vectors, " { $snippet "from-type" } " and " { $snippet "to-type" } " must have the same element length." } +{ "For packing conversions, " { $snippet "from-type" } " and " { $snippet "to-type" } " must be both floating-point or both integer types. Integer types can be packed from signed to unsigned or from unsigned to unsigned types. Unsigned to signed packing is invalid." } +{ "For unpacking conversions, " { $snippet "from-type" } " and " { $snippet "to-type" } " must be both floating-point or both integer types. Integer types can be unpacked from unsigned to signed or from unsigned to unsigned types. Signed to unsigned unpacking is invalid." } +} +} +{ $examples +"Conversion between integer and float vectors:" +{ $example """USING: alien.c-types math.vectors.conversion math.vectors.simd +prettyprint ; +SIMDS: int float longlong double ; + +int-8{ 0 1 2 3 4 5 6 7 } int-8 float-8 vconvert . +double-2{ 1.25 3.75 } double-2 longlong-2 vconvert .""" +"""float-8{ 0.0 1.0 2.0 3.0 4.0 5.0 6.0 7.0 } +longlong-2{ 1 3 }""" } +"Packing conversions:" +{ $example """USING: alien.c-types math.vectors.conversion math.vectors.simd +prettyprint ; +SIMDS: ushort int float double ; + +int-4{ -8 70000 6000 50 } int-4{ 4 3 2 -1 } int-4 ushort-8 vconvert . +double-4{ 0.0 1.5 1.0e100 2.0 } +double-4{ -1.0e100 0.0 1.0 2.0 } double-4 float-8 vconvert .""" +"""ushort-8{ 0 65535 6000 50 4 3 2 0 } +float-8{ 0.0 1.5 1/0. 2.0 -1/0. 0.0 1.0 2.0 }""" } +"Unpacking conversions:" +{ $example """USING: alien.c-types kernel math.vectors.conversion +math.vectors.simd prettyprint ; +SIMDS: uchar short ; + +uchar-16{ 8 70 60 50 4 30 200 1 9 10 110 102 133 143 115 0 } +uchar-16 short-8 vconvert [ . ] bi@""" +"""short-8{ 8 70 60 50 4 30 200 1 } +short-8{ 9 10 110 102 133 143 115 0 }""" } +} ; + +ARTICLE: "math.vectors.conversion" "SIMD vector conversion" +"The " { $vocab-link "math.vectors.conversion" } " vocabulary provides facilities for converting SIMD vectors between floating-point and integer representations and between different-sized integer representations." +{ $subsections + vconvert +} ; + +ABOUT: "math.vectors.conversion" diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index fdb742a721..480981d165 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -280,6 +280,7 @@ simd new } >>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 } diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 1bd5834f2c..649e444915 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -163,8 +163,8 @@ M: vector-rep supported-simd-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 ] } @@ -193,12 +193,12 @@ M: vector-rep supported-simd-op? { \ (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 ] } diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 62ebecff36..3ff286d508 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -7,12 +7,20 @@ 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 ] } @@ -32,6 +40,7 @@ SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; [ { { +vector+ [ drop ] } + { +any-vector+ [ drop parent-vector-class ] } { +scalar+ [ nip ] } { +boolean+ [ 2drop boolean ] } { @@ -101,7 +110,7 @@ H{ { 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+ } } diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 7a9aff49b6..b831ac7dbe 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -55,12 +55,15 @@ ARTICLE: "math-vectors-shuffle" "Vector shuffling, packing, and unpacking" "These operations are primarily meant to be used with " { $vocab-link "math.vectors.simd" } " types. The software fallbacks for types not supported by hardware will not perform well." } $nl -{ $subsection vshuffle } -{ $subsection vbroadcast } -{ $subsection hlshift } -{ $subsection hrshift } -{ $subsection vmerge } -{ $subsection (vmerge) } ; +{ $subsections + vshuffle + vbroadcast + hlshift + hrshift + vmerge + (vmerge) +} +"See the " { $vocab-link "math.vectors.conversion" } " vocabulary for packing, unpacking, and converting vectors." ; ARTICLE: "math-vectors-logic" "Vector component- and bit-wise logic" { $notes @@ -98,6 +101,7 @@ $nl vxor vnot v? + vif } "Entire vector tests:" { $subsections @@ -416,8 +420,12 @@ HELP: vbroadcast } ; HELP: vshuffle -{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } } -{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." } +{ $values { "u" "a SIMD array" } { "perm" "an array of integers, or a byte-array" } { "v" "a SIMD array" } } +{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation. The " { $snippet "perm" } " argument can have one of two forms:" +{ $list +{ "A literal array of integers of the same length as the vector. This will perform a static, elementwise shuffle." } +{ "A byte array or SIMD vector of the same byte length as the vector. This will perform a variable bytewise shuffle." } +} } { $examples { $example "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;" @@ -425,6 +433,29 @@ HELP: vshuffle "int-4{ 69 42 911 13 } { 1 3 2 3 } vshuffle ." "int-4{ 42 13 911 13 }" } + { $example + "USING: alien.c-types combinators math.vectors math.vectors.simd" + "namespaces prettyprint prettyprint.config ;" + "SIMDS: int uchar ;" + "IN: scratchpad" + "" + ": endian-swap ( size -- vector )" + " {" + " { 1 [ uchar-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 } ] }" + " { 2 [ uchar-16{ 1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14 } ] }" + " { 4 [ uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } ] }" + " } case ;" + "" + "int-4{ HEX: 11223344 HEX: 11223344 HEX: 11223344 HEX: 11223344 }" + "4 endian-swap vshuffle" + "16 number-base [ . ] with-variable" + """int-4{ + HEX: 44332211 + HEX: 44332211 + HEX: 44332211 + HEX: 44332211 +}""" + } } ; HELP: norm-sq @@ -504,10 +535,19 @@ HELP: vnot { $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." } diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 0a984ba2e7..81af5c12d2 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -1,8 +1,8 @@ ! 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 @@ -29,8 +29,16 @@ M: object element-type drop f ; inline : [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 ; + + + +: 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 @@ -92,7 +100,7 @@ PRIVATE> : 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 ) @@ -134,9 +142,16 @@ M: simd-128 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 ; @@ -163,24 +178,24 @@ PRIVATE> : 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 } ; diff --git a/basis/peg/ebnf/ebnf-docs.factor b/basis/peg/ebnf/ebnf-docs.factor new file mode 100644 index 0000000000..9bfd8ce499 --- /dev/null +++ b/basis/peg/ebnf/ebnf-docs.factor @@ -0,0 +1,474 @@ +! 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: " } +{ $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\" [[ 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 ;" + "\"\" [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 ;" + "\"\" [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 '' or ''. 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 = " + ";EBNF" + "EBNF: parse-two-strings" + "TwoString = " + ";EBNF" + } + { $code + ": a-token ( -- parser ) \"a\" token ;" + "EBNF: parse-abc" + "abc = '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 = " + "" + "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 = " + "..." + "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: > ] curry ; +PRIVATE> + SYNTAX: " reset-tokenizer parse-multiline-string parse-ebnf main swap at diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index 28883838ce..55606217c9 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types kernel locals math math.ranges 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 @@ -28,14 +28,25 @@ TUPLE: 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 diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 50e94b65e9..68ce02e71e 100755 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -86,7 +86,7 @@ ARTICLE: "specialized-array-examples" "Specialized array examples" 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: diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 1ee8776085..423c7ad1ee 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -4,7 +4,7 @@ specialized-arrays.private sequences alien.c-types accessors 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 @@ -120,10 +120,7 @@ SPECIALIZED-ARRAY: fixed-string [ "int-array@ f 100" ] [ f 100 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__ [ """ @@ -146,6 +143,13 @@ SPECIALIZED-ARRAY: __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 diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index c5de95b5b5..67c58987a1 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -6,7 +6,7 @@ libc math math.vectors math.vectors.private 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 @@ -125,11 +125,13 @@ M: word (underlying-type) "c-type" word-prop ; [ 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> @@ -143,18 +145,18 @@ M: c-type-name require-c-array define-array-vocab drop ; 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 [ "" surround ] [ specialized-array-vocab ] bi lookup + underlying-type + dup [ name>> "" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable SYNTAX: SPECIALIZED-ARRAYS: diff --git a/basis/specialized-vectors/specialized-vectors-docs.factor b/basis/specialized-vectors/specialized-vectors-docs.factor index 6b53885e13..e54f26ac57 100644 --- a/basis/specialized-vectors/specialized-vectors-docs.factor +++ b/basis/specialized-vectors/specialized-vectors-docs.factor @@ -6,6 +6,13 @@ HELP: SPECIALIZED-VECTOR: { $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 @@ -21,6 +28,12 @@ ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions" 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" diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor index c7a045a7e1..1519ad415e 100644 --- a/basis/specialized-vectors/specialized-vectors-tests.factor +++ b/basis/specialized-vectors/specialized-vectors-tests.factor @@ -2,8 +2,7 @@ IN: specialized-vectors.tests 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 diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 7cda026cb3..75197d9ec0 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -1,9 +1,10 @@ ! 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 @@ -41,8 +42,13 @@ INSTANCE: V S ;FUNCTOR -: specialized-vector-vocab ( type -- vocab ) - "specialized-vectors.instances." prepend ; +: specialized-vector-vocab ( c-type -- vocab ) + [ + "specialized-vectors.instances." % + [ vocabulary>> % "." % ] + [ name>> % ] + bi + ] "" make ; PRIVATE> @@ -51,7 +57,14 @@ 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 ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5f202b1781..97155bc6d9 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -54,7 +54,7 @@ $nl { $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 @@ -74,7 +74,7 @@ $nl "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." @@ -82,7 +82,7 @@ $nl "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:" diff --git a/basis/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor index 5f83eb268b..0c21597a2f 100644 --- a/basis/system-info/linux/linux.factor +++ b/basis/system-info/linux/linux.factor @@ -7,7 +7,7 @@ SPECIALIZED-ARRAY: char IN: system-info.linux : (uname) ( buf -- int ) - "int" f "uname" { "char*" } alien-invoke ; + int f "uname" { char* } alien-invoke ; : uname ( -- seq ) 65536 [ (uname) io-error ] keep diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e2d6f774e1..784b034665 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -22,7 +22,7 @@ IN: tools.deploy.tests [ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test -[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test +[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test @@ -114,4 +114,4 @@ os macosx? [ rest ] unit-test -[ ] [ "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 diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor index d6caa0e68b..65fd50b5b8 100644 --- a/basis/tools/deploy/test/14/14.factor +++ b/basis/tools/deploy/test/14/14.factor @@ -1,7 +1,9 @@ ! 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: { @@ -9,8 +11,8 @@ CLASS: { { +name+ "Bar" } } { "bar:" - "float" - { "id" "SEL" "NSRect" } + float + { id SEL NSRect } [ [ origin>> [ x>> ] [ y>> ] bi + ] [ size>> [ w>> ] [ h>> ] bi + ] diff --git a/basis/tools/deploy/test/9/9.factor b/basis/tools/deploy/test/9/9.factor index a1cbd5bc66..642ee48e67 100644 --- a/basis/tools/deploy/test/9/9.factor +++ b/basis/tools/deploy/test/9/9.factor @@ -1,10 +1,10 @@ -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 diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index 908540254a..c799ec615e 100755 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -25,4 +25,4 @@ IN: tools.deploy.test "-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 ; diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index dda531faee..f7da0d1636 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -21,9 +21,9 @@ words ; [ ] [ \ + 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 ( -- ) ; diff --git a/basis/typed/debugger/debugger.factor b/basis/typed/debugger/debugger.factor index c5f83c0378..dae30fa9d8 100644 --- a/basis/typed/debugger/debugger.factor +++ b/basis/typed/debugger/debugger.factor @@ -1,5 +1,6 @@ ! (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 ) @@ -8,3 +9,6 @@ IN: typed.debugger "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 diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 0213b8433c..a262b549f2 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -218,7 +218,7 @@ CLASS: { { +name+ "FactorApplicationDelegate" } } -{ "applicationDidUpdate:" "void" { "id" "SEL" "id" } +{ "applicationDidUpdate:" void { id SEL id } [ 3drop reset-run-loop ] } ; diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index b8c01f0bd9..d04bcededa 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -1,11 +1,12 @@ ! 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 -- ) @@ -25,43 +26,43 @@ CLASS: { { +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 ] } ; @@ -79,13 +80,13 @@ CLASS: { { +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 ] } ; diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 9577696314..88e5f243ad 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -3,8 +3,8 @@ 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 @@ -148,76 +148,76 @@ CLASS: { } ! 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 @@ -225,57 +225,57 @@ CLASS: { ] } -{ "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 { @@ -286,7 +286,7 @@ CLASS: { ] } -{ "swipeWithEvent:" "void" { "id" "SEL" "id" } +{ "swipeWithEvent:" void { id SEL id } [ nip dup -> deltaX sgn { @@ -305,14 +305,14 @@ CLASS: { ] } -! "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 @@ -320,7 +320,7 @@ CLASS: { ] } -{ "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 @@ -329,7 +329,7 @@ CLASS: { ] } -{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" } +{ "readSelectionFromPasteboard:" char { id SEL id } [ pasteboard-string dup [ [ drop window ] dip swap user-input 1 @@ -338,60 +338,60 @@ CLASS: { } ! 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 ] } -{ "selectedRange" "NSRange" { "id" "SEL" } +{ "selectedRange" NSRange { id SEL } [ 2drop 0 0 ] } -{ "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 ] } -{ "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: @@ -399,13 +399,13 @@ CLASS: { ] } -{ "isOpaque" "char" { "id" "SEL" } +{ "isOpaque" char { id SEL } [ 2drop 0 ] } -{ "dealloc" "void" { "id" "SEL" } +{ "dealloc" void { id SEL } [ drop [ unregister-window ] @@ -430,19 +430,19 @@ CLASS: { { +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 @@ -452,13 +452,13 @@ CLASS: { ] } -{ "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 ] diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 0e07ff6611..7dbe3a3c48 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -596,7 +596,7 @@ SYMBOL: trace-messages? ! 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 diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index 3ba32dc3c2..3fbdf12cbe 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -1,8 +1,8 @@ -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" ] [ @@ -55,6 +55,9 @@ IN: ui.gadgets.editors.tests [ ] [ com-join-lines ] unit-test [ ] [ "A" over set-editor-string com-join-lines ] unit-test [ "A B" ] [ "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test +[ "A B\nC\nD" ] [ "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" ] [ "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" ] [ "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 ] [ 20 >>min-rows 20 >>min-cols pref-viewport-dim length ] unit-test diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index f83c5d710a..071ac1cffe 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -17,6 +17,8 @@ caret-color caret mark focused? blink blink-alarm ; + ( -- loc ) { 0 0 } ; : init-editor-locs ( editor -- editor ) @@ -27,6 +29,8 @@ focused? blink blink-alarm ; COLOR: red >>caret-color monospace-font >>font ; inline +PRIVATE> + : new-editor ( class -- editor ) new-line-gadget >>model @@ -36,6 +40,8 @@ focused? blink blink-alarm ; : ( -- editor ) editor new-editor ; + + M: editor graft* [ dup caret>> activate-editor-model ] [ dup mark>> activate-editor-model ] bi ; @@ -142,6 +150,8 @@ M: editor ungraft* ] keep scroll>rect ] [ drop ] if ; +> ] [ blink>> ] } 1&& ; @@ -189,6 +199,8 @@ TUPLE: selected-line start end first? last? ; ] 3bi ] if ; +PRIVATE> + M: editor draw-line ( line index editor -- ) [ selected-lines get at ] dip over [ draw-selected-line ] [ nip draw-unselected-line ] if ; @@ -206,6 +218,8 @@ M: editor baseline font>> font-metrics ascent>> ; M: editor cap-height font>> font-metrics cap-height>> ; +> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] @@ -214,6 +228,8 @@ M: editor cap-height font>> font-metrics cap-height>> ; : caret/mark-changed ( editor -- ) [ restart-blinking ] keep scroll>caret ; +PRIVATE> + M: editor model-changed { { [ 2dup model>> eq? ] [ contents-changed ] } @@ -513,6 +529,8 @@ PRIVATE> : change-selection ( editor quot -- ) '[ gadget-selection @ ] [ user-input* drop ] bi ; inline + [ " " 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 { @@ -566,6 +601,8 @@ TUPLE: source-editor < multiline-editor ; ! Fields wrap an editor TUPLE: field < border editor min-cols max-cols ; +>size { 1 0 } >>fill @@ -576,6 +613,8 @@ TUPLE: field < border editor min-cols max-cols ; { 1 0 } >>fill field-theme ; +PRIVATE> + : new-field ( class -- gadget ) [ ] dip new-border dup gadget-child >>editor diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 70c104e2df..54d3fe6f4d 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -759,6 +759,34 @@ CONSTANT: PIPE_NOWAIT 1 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 diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 9fb9c042ee..6787d3714b 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -79,7 +79,7 @@ HELP: alien-callback-error 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 @@ -90,7 +90,7 @@ HELP: alien-callback "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." } ; diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor index 9d41239206..ecc484df11 100644 --- a/core/classes/builtin/builtin-docs.factor +++ b/core/classes/builtin/builtin-docs.factor @@ -9,7 +9,7 @@ $nl 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." } diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index 554e287a3b..0f6c9bc0cd 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -4,7 +4,8 @@ accessors words byte-arrays bit-arrays parser namespaces make 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' ) diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index 7ddd58468a..561110d941 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,13 +1,13 @@ -USING: math kernel alien ; +USING: math kernel alien alien.c-types ; IN: benchmark.fib6 : fib ( x -- y ) - "int" { "int" } "cdecl" [ + int { int } "cdecl" [ dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] if ] alien-callback - "int" { "int" } "cdecl" alien-indirect ; + int { int } "cdecl" alien-indirect ; : fib-main ( -- ) 32 fib drop ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 04c47caf4a..ddea7e762a 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -24,7 +24,6 @@ USING: quotations sequences sequences.deep - syntax words ; IN: cpu.8080.emulator diff --git a/extra/decimals/decimals-tests.factor b/extra/decimals/decimals-tests.factor index bb9e60cfc1..29b9d98b38 100644 --- a/extra/decimals/decimals-tests.factor +++ b/extra/decimals/decimals-tests.factor @@ -49,3 +49,4 @@ ERROR: decimal-test-failure D1 D2 quot ; [ 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 diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index d9bafd43d0..ae1fb2f9a3 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -37,8 +37,7 @@ SYNTAX: D: parse-decimal parsed ; ] 2bi ; : scale-decimals ( D1 D2 -- D1' D2' ) - [ drop ] - [ scale-mantissas nip ] 2bi ; + scale-mantissas tuck [ ] 2dip ; ERROR: decimal-types-expected d1 d2 ; @@ -83,3 +82,6 @@ M: decimal before? e1 e2 a + - ; + +M: decimal <=> + 2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index fdaa510e02..629a3ad662 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -226,6 +226,11 @@ HELP: render-set } } { $notes "User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions. Disabling rasterization requires OpenGL 3.0 or the " { $snippet "GL_EXT_transform_feedback" } " extension. Named output-attachment values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension. Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ; +HELP: bind-uniforms +{ $values { "program-instance" program-instance } { "uniforms" uniform-tuple } } +{ $description "Binds the uniform shader parameters for " { $snippet "program-instance" } " using values from the given uniform tuple." } +{ $notes "The " { $link render } " word uses this word. Calling this word directly is only necessary if uniform parameters need to be bound independently of a " { $snippet "render" } " operation." } ; + { render render-set } related-words HELP: texture-uniform diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 4f2437c0c1..5f92cf3dbf 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -168,12 +168,12 @@ M: multi-index-elements render-vertex-indexes : (bind-texture-unit) ( texture texture-unit -- ) swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline -GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- ) -GENERIC: bind-uniforms ( program-instance uniform-tuple -- ) +GENERIC: (bind-uniform-textures) ( program-instance uniform-tuple -- ) +GENERIC: (bind-uniforms) ( program-instance uniform-tuple -- ) -M: uniform-tuple bind-uniform-textures +M: uniform-tuple (bind-uniform-textures) 2drop ; -M: uniform-tuple bind-uniforms +M: uniform-tuple (bind-uniforms) 2drop ; : uniform-slot-type ( uniform -- type ) @@ -363,7 +363,7 @@ DEFER: [bind-uniform-tuple] :: [bind-uniforms] ( superclass uniforms -- quot ) superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit - superclass \ bind-uniforms method :> next-method + superclass \ (bind-uniforms) method :> next-method first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot { 2dup next-method } bind-quot [ ] append-as ; @@ -371,10 +371,10 @@ DEFER: [bind-uniform-tuple] : define-uniform-tuple-methods ( class superclass uniforms -- ) [ 2drop - [ \ bind-uniform-textures create-method-in ] + [ \ (bind-uniform-textures) create-method-in ] [ [bind-uniform-textures] ] bi define ] [ - [ \ bind-uniforms create-method-in ] 2dip + [ \ (bind-uniforms) create-method-in ] 2dip [bind-uniforms] define ] 3bi ; @@ -481,12 +481,15 @@ TUPLE: render-set : 3 ( x y z quot-assoc -- render-set ) render-set swap 3make-tuple ; inline +: bind-uniforms ( program-instance uniforms -- ) + [ (bind-uniform-textures) ] [ (bind-uniforms) ] 2bi ; inline + : render ( render-set -- ) { [ vertex-array>> program-instance>> handle>> glUseProgram ] [ [ vertex-array>> program-instance>> ] [ uniforms>> ] bi - [ bind-uniform-textures ] [ bind-uniforms ] 2bi + bind-uniforms ] [ framebuffer>> diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 0af5e9ac57..aece1b40d6 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -432,33 +432,49 @@ PRIVATE> : ( program -- instance ) [ find-program-instance dup world get ] keep instances>> set-at ; +> ] [ drop H{ } clone ] if + ] [ drop H{ } clone ] if ; + +PRIVATE> + SYNTAX: GLSL-SHADER: - CREATE-WORD dup - scan-word - f - lexer get line>> - parse-here - H{ } clone + CREATE dup + dup old-instances [ + scan-word + f + lexer get line>> + parse-here + ] dip shader boa + over reset-generic define-constant ; SYNTAX: GLSL-SHADER-FILE: - CREATE-WORD dup - scan-word execute( -- kind ) - scan-object in-word's-path - 0 - over ascii file-contents - H{ } clone + CREATE dup + dup old-instances [ + scan-word execute( -- kind ) + scan-object in-word's-path + 0 + over ascii file-contents + ] dip shader boa + over reset-generic define-constant ; SYNTAX: GLSL-PROGRAM: - CREATE-WORD dup - f - lexer get line>> - \ ; parse-until >array shaders-and-feedback-format - H{ } clone + CREATE dup + dup old-instances [ + f + lexer get line>> + \ ; parse-until >array shaders-and-feedback-format + ] dip program boa + over reset-generic define-constant ; M: shader-instance dispose diff --git a/extra/modules/rpc-server/authors.txt b/extra/modules/rpc-server/authors.txt deleted file mode 100644 index 2300f69f11..0000000000 --- a/extra/modules/rpc-server/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria diff --git a/extra/modules/rpc-server/rpc-server-docs.factor b/extra/modules/rpc-server/rpc-server-docs.factor deleted file mode 100644 index fc2c2344dd..0000000000 --- a/extra/modules/rpc-server/rpc-server-docs.factor +++ /dev/null @@ -1,5 +0,0 @@ -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 diff --git a/extra/modules/rpc-server/rpc-server.factor b/extra/modules/rpc-server/rpc-server.factor deleted file mode 100644 index d82f13f715..0000000000 --- a/extra/modules/rpc-server/rpc-server.factor +++ /dev/null @@ -1,31 +0,0 @@ -! 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 - -> 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 - "rpcs" >>name 9012 >>insecure - [ deserialize { - { "getter" [ getter ] } - { "doer" [ doer ] } - { "loader" [ deserialize vocab serialize flush ] } - } case ] >>handler - start-server ; diff --git a/extra/modules/rpc-server/summary.txt b/extra/modules/rpc-server/summary.txt deleted file mode 100644 index 3688644814..0000000000 --- a/extra/modules/rpc-server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Serve factor words as rpcs \ No newline at end of file diff --git a/extra/modules/rpc/authors.txt b/extra/modules/rpc/authors.txt deleted file mode 100644 index 2300f69f11..0000000000 --- a/extra/modules/rpc/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria diff --git a/extra/modules/rpc/rpc-docs.factor b/extra/modules/rpc/rpc-docs.factor deleted file mode 100644 index af99d210ab..0000000000 --- a/extra/modules/rpc/rpc-docs.factor +++ /dev/null @@ -1,9 +0,0 @@ -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 diff --git a/extra/modules/rpc/rpc.factor b/extra/modules/rpc/rpc.factor deleted file mode 100644 index b394090d55..0000000000 --- a/extra/modules/rpc/rpc.factor +++ /dev/null @@ -1,27 +0,0 @@ -! 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 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 binary [ "getter" serialize send-with-check ] with-client - [ first2 addrspec vocabspec define-remote ] each - ] unless ; - -: remote-load ( addr vocabspec -- voabspec ) [ swap - 9012 binary [ "loader" serialize serialize flush deserialize ] with-client ] keep - [ dictionary get-global set-at ] keep ; \ No newline at end of file diff --git a/extra/modules/rpc/summary.txt b/extra/modules/rpc/summary.txt deleted file mode 100644 index cc1501fa88..0000000000 --- a/extra/modules/rpc/summary.txt +++ /dev/null @@ -1 +0,0 @@ -remote procedure call client \ No newline at end of file diff --git a/extra/modules/using/authors.txt b/extra/modules/using/authors.txt deleted file mode 100644 index 2300f69f11..0000000000 --- a/extra/modules/using/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria diff --git a/extra/modules/using/summary.txt b/extra/modules/using/summary.txt deleted file mode 100644 index 62fdb05d5b..0000000000 --- a/extra/modules/using/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Improved module import syntax with network transparency \ No newline at end of file diff --git a/extra/modules/using/using-docs.factor b/extra/modules/using/using-docs.factor deleted file mode 100644 index 0f67f2b0ee..0000000000 --- a/extra/modules/using/using-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -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 diff --git a/extra/modules/using/using.factor b/extra/modules/using/using.factor deleted file mode 100644 index 5691caaf6a..0000000000 --- a/extra/modules/using/using.factor +++ /dev/null @@ -1,28 +0,0 @@ -! 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 = -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 diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 1ea5b95157..91e040d35f 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -56,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ; 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 diff --git a/extra/peg-lexer/authors.txt b/extra/peg-lexer/authors.txt deleted file mode 100644 index ce0899f16e..0000000000 --- a/extra/peg-lexer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria \ No newline at end of file diff --git a/extra/peg-lexer/peg-lexer-docs.factor b/extra/peg-lexer/peg-lexer-docs.factor deleted file mode 100644 index 18a458e8ff..0000000000 --- a/extra/peg-lexer/peg-lexer-docs.factor +++ /dev/null @@ -1,14 +0,0 @@ -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 diff --git a/extra/peg-lexer/peg-lexer-tests.factor b/extra/peg-lexer/peg-lexer-tests.factor deleted file mode 100644 index 99a1397273..0000000000 --- a/extra/peg-lexer/peg-lexer-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -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 diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor deleted file mode 100644 index dcde55c91a..0000000000 --- a/extra/peg-lexer/peg-lexer.factor +++ /dev/null @@ -1,64 +0,0 @@ -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>> ; -: ( 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 - 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 diff --git a/extra/peg-lexer/summary.txt b/extra/peg-lexer/summary.txt deleted file mode 100755 index 2de36bada4..0000000000 --- a/extra/peg-lexer/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Use peg to write parsing words diff --git a/extra/peg-lexer/tags.txt b/extra/peg-lexer/tags.txt deleted file mode 100644 index 44385cf3b7..0000000000 --- a/extra/peg-lexer/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -extensions -reflection diff --git a/extra/peg-lexer/test-parsers/test-parsers.factor b/extra/peg-lexer/test-parsers/test-parsers.factor deleted file mode 100644 index 83c9f85933..0000000000 --- a/extra/peg-lexer/test-parsers/test-parsers.factor +++ /dev/null @@ -1,17 +0,0 @@ -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 = - expr= "heavy" "duty" "testing" -;ON-BNF \ No newline at end of file diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index b587dab29d..87db981f40 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -2,7 +2,7 @@ ! 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 { diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index 23e89bffdb..2d76c8df71 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,7 +1,7 @@ ! 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 diff --git a/extra/random/cmwc/cmwc-tests.factor b/extra/random/cmwc/cmwc-tests.factor index 8dc9f8764f..d5e1fe6858 100644 --- a/extra/random/cmwc/cmwc-tests.factor +++ b/extra/random/cmwc/cmwc-tests.factor @@ -1,7 +1,8 @@ ! 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 [ ] [ diff --git a/extra/random/cmwc/cmwc.factor b/extra/random/cmwc/cmwc.factor index 941840f23a..3fda392d80 100644 --- a/extra/random/cmwc/cmwc.factor +++ b/extra/random/cmwc/cmwc.factor @@ -2,7 +2,8 @@ ! 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 diff --git a/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor b/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor index e830c466c2..df90d4d40f 100644 --- a/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor +++ b/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor @@ -1,7 +1,8 @@ ! 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 ] [ diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index cb0f4319d6..cbe2241604 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -22,15 +22,13 @@ USING: 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 diff --git a/extra/ui/gadgets/controls/controls.factor b/extra/ui/gadgets/controls/controls.factor index 649c9052fd..0c7841b11f 100644 --- a/extra/ui/gadgets/controls/controls.factor +++ b/extra/ui/gadgets/controls/controls.factor @@ -1,7 +1,7 @@ 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 diff --git a/unmaintained/modules/rpc-server/authors.txt b/unmaintained/modules/rpc-server/authors.txt new file mode 100644 index 0000000000..2300f69f11 --- /dev/null +++ b/unmaintained/modules/rpc-server/authors.txt @@ -0,0 +1 @@ +Sam Anklesaria diff --git a/unmaintained/modules/rpc-server/rpc-server-docs.factor b/unmaintained/modules/rpc-server/rpc-server-docs.factor new file mode 100644 index 0000000000..fc2c2344dd --- /dev/null +++ b/unmaintained/modules/rpc-server/rpc-server-docs.factor @@ -0,0 +1,5 @@ +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 diff --git a/unmaintained/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor new file mode 100644 index 0000000000..d82f13f715 --- /dev/null +++ b/unmaintained/modules/rpc-server/rpc-server.factor @@ -0,0 +1,31 @@ +! 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 + +> 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 + "rpcs" >>name 9012 >>insecure + [ deserialize { + { "getter" [ getter ] } + { "doer" [ doer ] } + { "loader" [ deserialize vocab serialize flush ] } + } case ] >>handler + start-server ; diff --git a/unmaintained/modules/rpc-server/summary.txt b/unmaintained/modules/rpc-server/summary.txt new file mode 100644 index 0000000000..3688644814 --- /dev/null +++ b/unmaintained/modules/rpc-server/summary.txt @@ -0,0 +1 @@ +Serve factor words as rpcs \ No newline at end of file diff --git a/unmaintained/modules/rpc/authors.txt b/unmaintained/modules/rpc/authors.txt new file mode 100644 index 0000000000..2300f69f11 --- /dev/null +++ b/unmaintained/modules/rpc/authors.txt @@ -0,0 +1 @@ +Sam Anklesaria diff --git a/unmaintained/modules/rpc/rpc-docs.factor b/unmaintained/modules/rpc/rpc-docs.factor new file mode 100644 index 0000000000..af99d210ab --- /dev/null +++ b/unmaintained/modules/rpc/rpc-docs.factor @@ -0,0 +1,9 @@ +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 diff --git a/unmaintained/modules/rpc/rpc.factor b/unmaintained/modules/rpc/rpc.factor new file mode 100644 index 0000000000..b394090d55 --- /dev/null +++ b/unmaintained/modules/rpc/rpc.factor @@ -0,0 +1,27 @@ +! 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 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 binary [ "getter" serialize send-with-check ] with-client + [ first2 addrspec vocabspec define-remote ] each + ] unless ; + +: remote-load ( addr vocabspec -- voabspec ) [ swap + 9012 binary [ "loader" serialize serialize flush deserialize ] with-client ] keep + [ dictionary get-global set-at ] keep ; \ No newline at end of file diff --git a/unmaintained/modules/rpc/summary.txt b/unmaintained/modules/rpc/summary.txt new file mode 100644 index 0000000000..cc1501fa88 --- /dev/null +++ b/unmaintained/modules/rpc/summary.txt @@ -0,0 +1 @@ +remote procedure call client \ No newline at end of file diff --git a/unmaintained/modules/using/authors.txt b/unmaintained/modules/using/authors.txt new file mode 100644 index 0000000000..2300f69f11 --- /dev/null +++ b/unmaintained/modules/using/authors.txt @@ -0,0 +1 @@ +Sam Anklesaria diff --git a/unmaintained/modules/using/summary.txt b/unmaintained/modules/using/summary.txt new file mode 100644 index 0000000000..62fdb05d5b --- /dev/null +++ b/unmaintained/modules/using/summary.txt @@ -0,0 +1 @@ +Improved module import syntax with network transparency \ No newline at end of file diff --git a/unmaintained/modules/using/using-docs.factor b/unmaintained/modules/using/using-docs.factor new file mode 100644 index 0000000000..0f67f2b0ee --- /dev/null +++ b/unmaintained/modules/using/using-docs.factor @@ -0,0 +1,11 @@ +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 diff --git a/unmaintained/modules/using/using.factor b/unmaintained/modules/using/using.factor new file mode 100644 index 0000000000..5691caaf6a --- /dev/null +++ b/unmaintained/modules/using/using.factor @@ -0,0 +1,28 @@ +! 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 = +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 diff --git a/unmaintained/peg-lexer/authors.txt b/unmaintained/peg-lexer/authors.txt new file mode 100644 index 0000000000..ce0899f16e --- /dev/null +++ b/unmaintained/peg-lexer/authors.txt @@ -0,0 +1 @@ +Sam Anklesaria \ No newline at end of file diff --git a/unmaintained/peg-lexer/peg-lexer-docs.factor b/unmaintained/peg-lexer/peg-lexer-docs.factor new file mode 100644 index 0000000000..18a458e8ff --- /dev/null +++ b/unmaintained/peg-lexer/peg-lexer-docs.factor @@ -0,0 +1,14 @@ +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 diff --git a/unmaintained/peg-lexer/peg-lexer-tests.factor b/unmaintained/peg-lexer/peg-lexer-tests.factor new file mode 100644 index 0000000000..99a1397273 --- /dev/null +++ b/unmaintained/peg-lexer/peg-lexer-tests.factor @@ -0,0 +1,14 @@ +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 diff --git a/unmaintained/peg-lexer/peg-lexer.factor b/unmaintained/peg-lexer/peg-lexer.factor new file mode 100644 index 0000000000..dcde55c91a --- /dev/null +++ b/unmaintained/peg-lexer/peg-lexer.factor @@ -0,0 +1,64 @@ +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>> ; +: ( 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 + 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 diff --git a/unmaintained/peg-lexer/summary.txt b/unmaintained/peg-lexer/summary.txt new file mode 100755 index 0000000000..2de36bada4 --- /dev/null +++ b/unmaintained/peg-lexer/summary.txt @@ -0,0 +1 @@ +Use peg to write parsing words diff --git a/unmaintained/peg-lexer/tags.txt b/unmaintained/peg-lexer/tags.txt new file mode 100644 index 0000000000..44385cf3b7 --- /dev/null +++ b/unmaintained/peg-lexer/tags.txt @@ -0,0 +1,2 @@ +extensions +reflection diff --git a/unmaintained/peg-lexer/test-parsers/test-parsers.factor b/unmaintained/peg-lexer/test-parsers/test-parsers.factor new file mode 100644 index 0000000000..83c9f85933 --- /dev/null +++ b/unmaintained/peg-lexer/test-parsers/test-parsers.factor @@ -0,0 +1,17 @@ +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 = + expr= "heavy" "duty" "testing" +;ON-BNF \ No newline at end of file diff --git a/vm/aging_collector.cpp b/vm/aging_collector.cpp index 6e3e61412a..5e284be587 100644 --- a/vm/aging_collector.cpp +++ b/vm/aging_collector.cpp @@ -3,12 +3,12 @@ namespace factor { -aging_collector::aging_collector(factor_vm *myvm_) : +aging_collector::aging_collector(factor_vm *parent_) : copying_collector( - myvm_, - &myvm_->gc_stats.aging_stats, - myvm_->data->aging, - aging_policy(myvm_)) {} + parent_, + &parent_->gc_stats.aging_stats, + parent_->data->aging, + aging_policy(parent_)) {} void factor_vm::collect_aging() { diff --git a/vm/aging_collector.hpp b/vm/aging_collector.hpp index 2191797020..1fa82972ff 100644 --- a/vm/aging_collector.hpp +++ b/vm/aging_collector.hpp @@ -2,13 +2,13 @@ namespace factor { struct aging_policy { - factor_vm *myvm; + factor_vm *parent; zone *aging, *tenured; - aging_policy(factor_vm *myvm_) : - myvm(myvm_), - aging(myvm->data->aging), - tenured(myvm->data->tenured) {} + aging_policy(factor_vm *parent_) : + parent(parent_), + aging(parent->data->aging), + tenured(parent->data->tenured) {} bool should_copy_p(object *untagged) { @@ -17,7 +17,7 @@ struct aging_policy { }; struct aging_collector : copying_collector { - aging_collector(factor_vm *myvm_); + aging_collector(factor_vm *parent_); }; } diff --git a/vm/alien.cpp b/vm/alien.cpp index 84e40a4613..ed3adf5c9b 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -12,8 +12,8 @@ char *factor_vm::pinned_alien_offset(cell obj) case ALIEN_TYPE: { alien *ptr = untag(obj); - if(ptr->expired != F) - general_error(ERROR_EXPIRED,obj,F,NULL); + if(to_boolean(ptr->expired)) + general_error(ERROR_EXPIRED,obj,false_object,NULL); return pinned_alien_offset(ptr->base) + ptr->displacement; } case F_TYPE: @@ -40,7 +40,7 @@ cell factor_vm::allot_alien(cell delegate_, cell displacement) new_alien->base = delegate.value(); new_alien->displacement = displacement; - new_alien->expired = F; + new_alien->expired = false_object; return new_alien.value(); } @@ -51,8 +51,8 @@ void factor_vm::primitive_displaced_alien() cell alien = dpop(); cell displacement = to_cell(dpop()); - if(alien == F && displacement == 0) - dpush(F); + if(!to_boolean(alien) && displacement == 0) + dpush(false_object); else { switch(tagged(alien).type()) @@ -87,12 +87,12 @@ void *factor_vm::alien_pointer() #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ PRIMITIVE(alien_##name) \ { \ - ((factor_vm*)myvm)->boxer(*(type*)((factor_vm*)myvm)->alien_pointer()); \ + parent->boxer(*(type*)(parent->alien_pointer())); \ } \ PRIMITIVE(set_alien_##name) \ { \ - type *ptr = (type *)((factor_vm*)myvm)->alien_pointer(); \ - type value = ((factor_vm*)myvm)->to(dpop()); \ + type *ptr = (type *)parent->alien_pointer(); \ + type value = parent->to(dpop()); \ *ptr = value; \ } @@ -130,17 +130,17 @@ void factor_vm::primitive_dlsym() symbol_char *sym = name->data(); - if(library.value() == F) - box_alien(ffi_dlsym(NULL,sym)); - else + if(to_boolean(library.value())) { dll *d = untag_check(library.value()); if(d->dll == NULL) - dpush(F); + dpush(false_object); else box_alien(ffi_dlsym(d,sym)); } + else + box_alien(ffi_dlsym(NULL,sym)); } /* close a native library handle */ @@ -154,10 +154,10 @@ void factor_vm::primitive_dlclose() void factor_vm::primitive_dll_validp() { cell library = dpop(); - if(library == F) - dpush(T); + if(to_boolean(library)) + dpush(tag_boolean(untag_check(library)->dll != NULL)); else - dpush(untag_check(library)->dll == NULL ? F : T); + dpush(true_object); } /* gets the address of an object representing a C pointer */ @@ -170,8 +170,8 @@ char *factor_vm::alien_offset(cell obj) case ALIEN_TYPE: { alien *ptr = untag(obj); - if(ptr->expired != F) - general_error(ERROR_EXPIRED,obj,F,NULL); + if(to_boolean(ptr->expired)) + general_error(ERROR_EXPIRED,obj,false_object,NULL); return alien_offset(ptr->base) + ptr->displacement; } case F_TYPE: @@ -182,9 +182,9 @@ char *factor_vm::alien_offset(cell obj) } } -VM_C_API char *alien_offset(cell obj, factor_vm *myvm) +VM_C_API char *alien_offset(cell obj, factor_vm *parent) { - return myvm->alien_offset(obj); + return parent->alien_offset(obj); } /* pop an object representing a C pointer */ @@ -193,23 +193,23 @@ char *factor_vm::unbox_alien() return alien_offset(dpop()); } -VM_C_API char *unbox_alien(factor_vm *myvm) +VM_C_API char *unbox_alien(factor_vm *parent) { - return myvm->unbox_alien(); + return parent->unbox_alien(); } /* make an alien and push */ void factor_vm::box_alien(void *ptr) { if(ptr == NULL) - dpush(F); + dpush(false_object); else - dpush(allot_alien(F,(cell)ptr)); + dpush(allot_alien(false_object,(cell)ptr)); } -VM_C_API void box_alien(void *ptr, factor_vm *myvm) +VM_C_API void box_alien(void *ptr, factor_vm *parent) { - return myvm->box_alien(ptr); + return parent->box_alien(ptr); } /* for FFI calls passing structs by value */ @@ -218,9 +218,9 @@ void factor_vm::to_value_struct(cell src, void *dest, cell size) memcpy(dest,alien_offset(src),size); } -VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *myvm) +VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent) { - return myvm->to_value_struct(src,dest,size); + return parent->to_value_struct(src,dest,size); } /* for FFI callbacks receiving structs by value */ @@ -231,9 +231,9 @@ void factor_vm::box_value_struct(void *src, cell size) dpush(tag(bytes)); } -VM_C_API void box_value_struct(void *src, cell size,factor_vm *myvm) +VM_C_API void box_value_struct(void *src, cell size,factor_vm *parent) { - return myvm->box_value_struct(src,size); + return parent->box_value_struct(src,size); } /* On some x86 OSes, structs <= 8 bytes are returned in registers. */ @@ -245,9 +245,9 @@ void factor_vm::box_small_struct(cell x, cell y, cell size) box_value_struct(data,size); } -VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *myvm) +VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *parent) { - return myvm->box_small_struct(x,y,size); + return parent->box_small_struct(x,y,size); } /* On OS X/PPC, complex numbers are returned in registers. */ @@ -261,9 +261,9 @@ void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size) box_value_struct(data,size); } -VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *myvm) +VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent) { - return myvm->box_medium_struct(x1, x2, x3, x4, size); + return parent->box_medium_struct(x1, x2, x3, x4, size); } void factor_vm::primitive_vm_ptr() diff --git a/vm/arrays.cpp b/vm/arrays.cpp index b09ff5c5af..09c6998e69 100644 --- a/vm/arrays.cpp +++ b/vm/arrays.cpp @@ -71,33 +71,33 @@ void factor_vm::primitive_resize_array() void growable_array::add(cell elt_) { - factor_vm *parent_vm = elements.parent_vm; - gc_root elt(elt_,parent_vm); + factor_vm *parent = elements.parent; + gc_root elt(elt_,parent); if(count == array_capacity(elements.untagged())) - elements = parent_vm->reallot_array(elements.untagged(),count * 2); + elements = parent->reallot_array(elements.untagged(),count * 2); - parent_vm->set_array_nth(elements.untagged(),count++,elt.value()); + parent->set_array_nth(elements.untagged(),count++,elt.value()); } void growable_array::append(array *elts_) { - factor_vm *parent_vm = elements.parent_vm; - gc_root elts(elts_,parent_vm); + factor_vm *parent = elements.parent; + gc_root elts(elts_,parent); cell capacity = array_capacity(elts.untagged()); if(count + capacity > array_capacity(elements.untagged())) { - elements = parent_vm->reallot_array(elements.untagged(), + elements = parent->reallot_array(elements.untagged(), (count + capacity) * 2); } for(cell index = 0; index < capacity; index++) - parent_vm->set_array_nth(elements.untagged(),count++,array_nth(elts.untagged(),index)); + parent->set_array_nth(elements.untagged(),count++,array_nth(elts.untagged(),index)); } void growable_array::trim() { - factor_vm *parent_vm = elements.parent_vm; - elements = parent_vm->reallot_array(elements.untagged(),count); + factor_vm *parent = elements.parent; + elements = parent->reallot_array(elements.untagged(),count); } } diff --git a/vm/arrays.hpp b/vm/arrays.hpp index accf8b3b04..48be881230 100755 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -26,7 +26,8 @@ struct growable_array { cell count; gc_root elements; - explicit growable_array(factor_vm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {} + explicit growable_array(factor_vm *parent, cell capacity = 10) : + count(0), elements(parent->allot_array(capacity,false_object),parent) {} void add(cell elt); void append(array *elts); diff --git a/vm/booleans.cpp b/vm/booleans.cpp index f1f0230c13..a7871dcbcb 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -5,22 +5,17 @@ namespace factor void factor_vm::box_boolean(bool value) { - dpush(value ? T : F); + dpush(tag_boolean(value)); } -VM_C_API void box_boolean(bool value, factor_vm *myvm) +VM_C_API void box_boolean(bool value, factor_vm *parent) { - return myvm->box_boolean(value); + return parent->box_boolean(value); } -bool factor_vm::to_boolean(cell value) +VM_C_API bool to_boolean(cell value, factor_vm *parent) { - return value != F; -} - -VM_C_API bool to_boolean(cell value, factor_vm *myvm) -{ - return myvm->to_boolean(value); + return parent->to_boolean(value); } } diff --git a/vm/booleans.hpp b/vm/booleans.hpp index 498c3f74be..375c8e3756 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -6,7 +6,12 @@ VM_C_API bool to_boolean(cell value, factor_vm *vm); inline cell factor_vm::tag_boolean(cell untagged) { - return (untagged ? T : F); + return (untagged ? true_object : false_object); +} + +inline bool factor_vm::to_boolean(cell value) +{ + return value != false_object; } } diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 91155c96d2..56b5db7ad8 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -32,9 +32,9 @@ void factor_vm::primitive_resize_byte_array() void growable_byte_array::append_bytes(void *elts, cell len) { cell new_size = count + len; - factor_vm *parent_vm = elements.parent_vm; + factor_vm *parent = elements.parent; if(new_size >= array_capacity(elements.untagged())) - elements = parent_vm->reallot_array(elements.untagged(),new_size * 2); + elements = parent->reallot_array(elements.untagged(),new_size * 2); memcpy(&elements->data()[count],elts,len); @@ -43,13 +43,13 @@ void growable_byte_array::append_bytes(void *elts, cell len) void growable_byte_array::append_byte_array(cell byte_array_) { - gc_root byte_array(byte_array_,elements.parent_vm); + gc_root byte_array(byte_array_,elements.parent); cell len = array_capacity(byte_array.untagged()); cell new_size = count + len; - factor_vm *parent_vm = elements.parent_vm; + factor_vm *parent = elements.parent; if(new_size >= array_capacity(elements.untagged())) - elements = parent_vm->reallot_array(elements.untagged(),new_size * 2); + elements = parent->reallot_array(elements.untagged(),new_size * 2); memcpy(&elements->data()[count],byte_array->data(),len); @@ -58,8 +58,8 @@ void growable_byte_array::append_byte_array(cell byte_array_) void growable_byte_array::trim() { - factor_vm *parent_vm = elements.parent_vm; - elements = parent_vm->reallot_array(elements.untagged(),count); + factor_vm *parent = elements.parent; + elements = parent->reallot_array(elements.untagged(),count); } } diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index e5a1e6a842..8ca95d9d1e 100755 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -5,7 +5,7 @@ struct growable_byte_array { cell count; gc_root elements; - explicit growable_byte_array(factor_vm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { } + explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { } void append_bytes(void *elts, cell len); void append_byte_array(cell elts); diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp index 2401800a9a..dca0eb6c24 100644 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -3,10 +3,10 @@ namespace factor { -callback_heap::callback_heap(cell size, factor_vm *myvm_) : +callback_heap::callback_heap(cell size, factor_vm *parent_) : seg(new segment(size,true)), here(seg->start), - myvm(myvm_) {} + parent(parent_) {} callback_heap::~callback_heap() { @@ -21,12 +21,12 @@ void factor_vm::init_callbacks(cell size) void callback_heap::update(callback *stub) { - tagged code_template(myvm->userenv[CALLBACK_STUB]); + tagged code_template(parent->userenv[CALLBACK_STUB]); cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1)); cell offset = untag_fixnum(array_nth(code_template.untagged(),3)); - myvm->store_address_in_code_block(rel_class, + parent->store_address_in_code_block(rel_class, (cell)(stub + 1) + offset, (cell)(stub->compiled + 1)); @@ -35,7 +35,7 @@ void callback_heap::update(callback *stub) callback *callback_heap::add(code_block *compiled) { - tagged code_template(myvm->userenv[CALLBACK_STUB]); + tagged code_template(parent->userenv[CALLBACK_STUB]); tagged insns(array_nth(code_template.untagged(),0)); cell size = array_capacity(insns.untagged()); diff --git a/vm/callbacks.hpp b/vm/callbacks.hpp index 571c7713c7..c499ad4719 100644 --- a/vm/callbacks.hpp +++ b/vm/callbacks.hpp @@ -10,9 +10,9 @@ struct callback { struct callback_heap { segment *seg; cell here; - factor_vm *myvm; + factor_vm *parent; - explicit callback_heap(cell size, factor_vm *myvm); + explicit callback_heap(cell size, factor_vm *parent); ~callback_heap(); callback *add(code_block *compiled); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 0b7663e513..4721fc4ece 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -100,22 +100,22 @@ cell factor_vm::frame_scan(stack_frame *frame) case QUOTATION_TYPE: { cell quot = frame_executing(frame); - if(quot == F) - return F; - else + if(to_boolean(quot)) { char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this); char *quot_xt = (char *)(frame_code(frame) + 1); return tag_fixnum(quot_code_offset_to_scan( quot,(cell)(return_addr - quot_xt))); - } + } + else + return false_object; } case WORD_TYPE: - return F; + return false_object; default: critical_error("Bad frame type",frame_type(frame)); - return F; + return false_object; } } @@ -123,15 +123,15 @@ namespace { struct stack_frame_accumulator { - factor_vm *myvm; + factor_vm *parent; growable_array frames; - explicit stack_frame_accumulator(factor_vm *myvm_) : myvm(myvm_), frames(myvm_) {} + explicit stack_frame_accumulator(factor_vm *parent_) : parent(parent_), frames(parent_) {} void operator()(stack_frame *frame) { - gc_root executing(myvm->frame_executing(frame),myvm); - gc_root scan(myvm->frame_scan(frame),myvm); + gc_root executing(parent->frame_executing(frame),parent); + gc_root scan(parent->frame_scan(frame),parent); frames.add(executing.value()); frames.add(scan.value()); @@ -204,9 +204,9 @@ void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom) ctx->callstack_bottom = callstack_bottom; } -VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm) +VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *parent) { - return myvm->save_callstack_bottom(callstack_bottom); + return parent->save_callstack_bottom(callstack_bottom); } } diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 0afd98dd0f..1f77148b5c 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -66,7 +66,7 @@ void *factor_vm::object_xt(cell obj) void *factor_vm::xt_pic(word *w, cell tagged_quot) { - if(tagged_quot == F || max_pic_size == 0) + if(!to_boolean(tagged_quot) || max_pic_size == 0) return w->xt; else { @@ -92,7 +92,7 @@ void *factor_vm::word_xt_pic_tail(word *w) image load */ void factor_vm::undefined_symbol() { - general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); + general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object,NULL); } void undefined_symbol() @@ -106,7 +106,7 @@ void *factor_vm::get_rel_symbol(array *literals, cell index) cell symbol = array_nth(literals,index); cell library = array_nth(literals,index + 1); - dll *d = (library == F ? NULL : untag(library)); + dll *d = (to_boolean(library) ? untag(library) : NULL); if(d != NULL && !d->dll) return (void *)factor::undefined_symbol; @@ -147,8 +147,8 @@ void *factor_vm::get_rel_symbol(array *literals, cell index) cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block *compiled) { - array *literals = (compiled->literals == F - ? NULL : untag(compiled->literals)); + array *literals = (to_boolean(compiled->literals) + ? untag(compiled->literals) : NULL); cell offset = relocation_offset_of(rel) + (cell)compiled->xt(); #define ARG array_nth(literals,index) @@ -196,7 +196,7 @@ cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block template void factor_vm::iterate_relocations(code_block *compiled, Iterator &iter) { - if(compiled->relocation != F) + if(to_boolean(compiled->relocation)) { byte_array *relocation = untag(compiled->relocation); @@ -277,18 +277,18 @@ void factor_vm::store_address_in_code_block(cell klass, cell offset, fixnum abso } struct literal_references_updater { - factor_vm *myvm; + factor_vm *parent; - explicit literal_references_updater(factor_vm *myvm_) : myvm(myvm_) {} + explicit literal_references_updater(factor_vm *parent_) : parent(parent_) {} void operator()(relocation_entry rel, cell index, code_block *compiled) { - if(myvm->relocation_type_of(rel) == RT_IMMEDIATE) + if(parent->relocation_type_of(rel) == RT_IMMEDIATE) { - cell offset = myvm->relocation_offset_of(rel) + (cell)(compiled + 1); - array *literals = myvm->untag(compiled->literals); + cell offset = parent->relocation_offset_of(rel) + (cell)(compiled + 1); + array *literals = parent->untag(compiled->literals); fixnum absolute_value = array_nth(literals,index); - myvm->store_address_in_code_block(myvm->relocation_class_of(rel),offset,absolute_value); + parent->store_address_in_code_block(parent->relocation_class_of(rel),offset,absolute_value); } } }; @@ -308,9 +308,9 @@ void factor_vm::update_literal_references(code_block *compiled) void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) { #ifdef FACTOR_DEBUG - if(compiled->literals != F) + if(to_boolean(compiled->literals)) tagged(compiled->literals).untag_check(this); - if(compiled->relocation != F) + if(to_boolean(compiled->relocation)) tagged(compiled->relocation).untag_check(this); #endif @@ -320,14 +320,14 @@ void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_ } struct word_references_updater { - factor_vm *myvm; + factor_vm *parent; - explicit word_references_updater(factor_vm *myvm_) : myvm(myvm_) {} + explicit word_references_updater(factor_vm *parent_) : parent(parent_) {} void operator()(relocation_entry rel, cell index, code_block *compiled) { - relocation_type type = myvm->relocation_type_of(rel); + relocation_type type = parent->relocation_type_of(rel); if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) - myvm->relocate_code_block_step(rel,index,compiled); + parent->relocate_code_block_step(rel,index,compiled); } }; @@ -358,20 +358,20 @@ void factor_vm::update_word_references(code_block *compiled) /* This runs after a full collection */ struct literal_and_word_references_updater { - factor_vm *myvm; + factor_vm *parent; - explicit literal_and_word_references_updater(factor_vm *myvm_) : myvm(myvm_) {} + explicit literal_and_word_references_updater(factor_vm *parent_) : parent(parent_) {} void operator()(relocation_entry rel, cell index, code_block *compiled) { - relocation_type type = myvm->relocation_type_of(rel); + relocation_type type = parent->relocation_type_of(rel); switch(type) { case RT_IMMEDIATE: case RT_XT: case RT_XT_PIC: case RT_XT_PIC_TAIL: - myvm->relocate_code_block_step(rel,index,compiled); + parent->relocate_code_block_step(rel,index,compiled); break; default: break; @@ -399,13 +399,13 @@ void factor_vm::check_code_address(cell address) } struct code_block_relocator { - factor_vm *myvm; + factor_vm *parent; - explicit code_block_relocator(factor_vm *myvm_) : myvm(myvm_) {} + explicit code_block_relocator(factor_vm *parent_) : parent(parent_) {} void operator()(relocation_entry rel, cell index, code_block *compiled) { - myvm->relocate_code_block_step(rel,index,compiled); + parent->relocate_code_block_step(rel,index,compiled); } }; @@ -484,12 +484,12 @@ code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell /* slight space optimization */ if(relocation.type() == BYTE_ARRAY_TYPE && array_capacity(relocation.untagged()) == 0) - compiled->relocation = F; + compiled->relocation = false_object; else compiled->relocation = relocation.value(); if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0) - compiled->literals = F; + compiled->literals = false_object; else compiled->literals = literals.value(); @@ -497,7 +497,7 @@ code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell memcpy(compiled + 1,code.untagged() + 1,code_length); /* fixup labels */ - if(labels.value() != F) + if(to_boolean(labels.value())) fixup_labels(labels.as().untagged(),compiled); /* next time we do a minor GC, we have to scan the code heap for diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b7307dd7e6..288c2221f2 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -51,17 +51,17 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate) word->code = def->code; - if(word->pic_def != F) jit_compile(word->pic_def,relocate); - if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate); + if(to_boolean(word->pic_def)) jit_compile(word->pic_def,relocate); + if(to_boolean(word->pic_tail_def)) jit_compile(word->pic_tail_def,relocate); } struct word_updater { - factor_vm *myvm; + factor_vm *parent; - explicit word_updater(factor_vm *myvm_) : myvm(myvm_) {} + explicit word_updater(factor_vm *parent_) : parent(parent_) {} void operator()(code_block *compiled) { - myvm->update_word_references(compiled); + parent->update_word_references(compiled); } }; @@ -143,18 +143,18 @@ code_block *code_heap::forward_code_block(code_block *compiled) } struct callframe_forwarder { - factor_vm *myvm; + factor_vm *parent; - explicit callframe_forwarder(factor_vm *myvm_) : myvm(myvm_) {} + explicit callframe_forwarder(factor_vm *parent_) : parent(parent_) {} void operator()(stack_frame *frame) { - cell offset = (cell)FRAME_RETURN_ADDRESS(frame,myvm) - (cell)frame->xt; + cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt; - code_block *forwarded = myvm->code->forward_code_block(myvm->frame_code(frame)); + code_block *forwarded = parent->code->forward_code_block(parent->frame_code(frame)); frame->xt = forwarded->xt(); - FRAME_RETURN_ADDRESS(frame,myvm) = (void *)((cell)frame->xt + offset); + FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset); } }; @@ -164,7 +164,7 @@ void factor_vm::forward_object_xts() cell obj; - while((obj = next_object()) != F) + while(to_boolean(obj = next_object())) { switch(tagged(obj).type()) { @@ -251,7 +251,7 @@ struct stack_trace_stripper { void operator()(code_block *compiled) { - compiled->owner = F; + compiled->owner = false_object; } }; diff --git a/vm/collector.hpp b/vm/collector.hpp index 8156fd1693..bbaad1d570 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -2,7 +2,7 @@ namespace factor { template struct collector { - factor_vm *myvm; + factor_vm *parent; data_heap *data; code_heap *code; gc_state *current_gc; @@ -10,18 +10,18 @@ template struct collector { TargetGeneration *target; Policy policy; - explicit collector(factor_vm *myvm_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) : - myvm(myvm_), - data(myvm_->data), - code(myvm_->code), - current_gc(myvm_->current_gc), + explicit collector(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_) {} object *resolve_forwarding(object *untagged) { - myvm->check_data_pointer(untagged); + parent->check_data_pointer(untagged); /* is there another forwarding pointer? */ while(untagged->h.forwarding_pointer_p()) @@ -38,7 +38,7 @@ template struct collector { if(immediate_p(pointer)) return; - object *untagged = myvm->untag(pointer); + object *untagged = parent->untag(pointer); if(!policy.should_copy_p(untagged)) return; @@ -57,7 +57,7 @@ template struct collector { void trace_slots(object *ptr) { cell *slot = (cell *)ptr; - cell *end = (cell *)((cell)ptr + myvm->binary_payload_start(ptr)); + cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr)); if(slot != end) { @@ -68,7 +68,7 @@ template struct collector { object *promote_object(object *untagged) { - cell size = myvm->untagged_object_size(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); @@ -90,8 +90,8 @@ template struct collector { void trace_registered_locals() { - std::vector::const_iterator iter = myvm->gc_locals.begin(); - std::vector::const_iterator end = myvm->gc_locals.end(); + std::vector::const_iterator iter = parent->gc_locals.begin(); + std::vector::const_iterator end = parent->gc_locals.end(); for(; iter < end; iter++) trace_handle((cell *)(*iter)); @@ -99,8 +99,8 @@ template struct collector { void trace_registered_bignums() { - std::vector::const_iterator iter = myvm->gc_bignums.begin(); - std::vector::const_iterator end = myvm->gc_bignums.end(); + std::vector::const_iterator iter = parent->gc_bignums.begin(); + std::vector::const_iterator end = parent->gc_bignums.end(); for(; iter < end; iter++) { @@ -119,20 +119,20 @@ template struct collector { the user environment and extra roots registered by local_roots.hpp */ void trace_roots() { - trace_handle(&myvm->T); - trace_handle(&myvm->bignum_zero); - trace_handle(&myvm->bignum_pos_one); - trace_handle(&myvm->bignum_neg_one); + trace_handle(&parent->true_object); + trace_handle(&parent->bignum_zero); + trace_handle(&parent->bignum_pos_one); + trace_handle(&parent->bignum_neg_one); trace_registered_locals(); trace_registered_bignums(); - for(int i = 0; i < USER_ENV; i++) trace_handle(&myvm->userenv[i]); + for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]); } void trace_contexts() { - context *ctx = myvm->ctx; + context *ctx = parent->ctx; while(ctx) { diff --git a/vm/contexts.cpp b/vm/contexts.cpp index bed044250e..cc7029e7f1 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -91,9 +91,9 @@ void factor_vm::nest_stacks(stack_frame *magic_frame) reset_retainstack(); } -void nest_stacks(stack_frame *magic_frame, factor_vm *myvm) +void nest_stacks(stack_frame *magic_frame, factor_vm *parent) { - return myvm->nest_stacks(magic_frame); + return parent->nest_stacks(magic_frame); } /* called when leaving a compiled callback */ @@ -111,9 +111,9 @@ void factor_vm::unnest_stacks() dealloc_context(old_ctx); } -void unnest_stacks(factor_vm *myvm) +void unnest_stacks(factor_vm *parent) { - return myvm->unnest_stacks(); + return parent->unnest_stacks(); } /* called on startup */ @@ -143,13 +143,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top) void factor_vm::primitive_datastack() { if(!stack_to_array(ds_bot,ds)) - general_error(ERROR_DS_UNDERFLOW,F,F,NULL); + general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL); } void factor_vm::primitive_retainstack() { if(!stack_to_array(rs_bot,rs)) - general_error(ERROR_RS_UNDERFLOW,F,F,NULL); + general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL); } /* returns pointer to top of stack */ @@ -180,7 +180,7 @@ void factor_vm::primitive_check_datastack() fixnum saved_height = array_capacity(saved_datastack); fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell); if(current_height - height != saved_height) - dpush(F); + dpush(false_object); else { fixnum i; @@ -188,11 +188,11 @@ void factor_vm::primitive_check_datastack() { if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i)) { - dpush(F); + dpush(false_object); return; } } - dpush(T); + dpush(true_object); } } diff --git a/vm/copying_collector.hpp b/vm/copying_collector.hpp index 297e70e687..640d355bf4 100644 --- a/vm/copying_collector.hpp +++ b/vm/copying_collector.hpp @@ -15,8 +15,8 @@ template struct copying_collector : collector { cell scan; - explicit copying_collector(factor_vm *myvm_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) : - collector(myvm_,stats_,target_,policy_), scan(target_->here) {} + explicit copying_collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) : + collector(parent_,stats_,target_,policy_), scan(target_->here) {} inline cell first_card_in_deck(cell deck) { @@ -82,7 +82,7 @@ struct copying_collector : collector { { if(decks[deck_index] & mask) { - this->myvm->gc_stats.decks_scanned++; + this->parent->gc_stats.decks_scanned++; cell first_card = first_card_in_deck(deck_index); cell last_card = last_card_in_deck(deck_index); @@ -91,13 +91,13 @@ struct copying_collector : collector { { if(cards[card_index] & mask) { - this->myvm->gc_stats.cards_scanned++; + 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->myvm->binary_payload_start((object *)start); - end = start + this->myvm->untagged_object_size((object *)start); + binary_start = start + this->parent->binary_payload_start((object *)start); + end = start + this->parent->untagged_object_size((object *)start); } #ifdef FACTOR_DEBUG @@ -113,11 +113,11 @@ scan_next_object: { card_end_address(card_index)); if(end < card_end_address(card_index)) { - start = gen->next_object_after(this->myvm,start); + start = gen->next_object_after(this->parent,start); if(start) { - binary_start = start + this->myvm->binary_payload_start((object *)start); - end = start + this->myvm->untagged_object_size((object *)start); + binary_start = start + this->parent->binary_payload_start((object *)start); + end = start + this->parent->untagged_object_size((object *)start); goto scan_next_object; } } @@ -133,7 +133,7 @@ scan_next_object: { } } -end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time); +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 */ @@ -142,7 +142,7 @@ end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time); this->trace_handle(&compiled->owner); this->trace_handle(&compiled->literals); this->trace_handle(&compiled->relocation); - this->myvm->gc_stats.code_blocks_scanned++; + this->parent->gc_stats.code_blocks_scanned++; } void trace_code_heap_roots(std::set *remembered_set) @@ -158,7 +158,7 @@ end: this->myvm->gc_stats.card_scan_time += (current_micros() - start_time); while(scan && scan < this->target->here) { this->trace_slots((object *)scan); - scan = this->target->next_object_after(this->myvm,scan); + scan = this->target->next_object_after(this->parent,scan); } } }; diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 6b09953314..335938acab 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -240,10 +240,10 @@ void factor_vm::primitive_begin_scan() cell factor_vm::next_object() { if(!gc_off) - general_error(ERROR_HEAP_SCAN,F,F,NULL); + general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL); if(heap_scan_ptr >= data->tenured->here) - return F; + return false_object; object *obj = (object *)heap_scan_ptr; heap_scan_ptr += untagged_object_size(obj); @@ -266,7 +266,7 @@ template void factor_vm::each_object(Iterator &iterator) { begin_scan(); cell obj; - while((obj = next_object()) != F) + while(to_boolean(obj = next_object())) iterator(tagged(obj)); end_scan(); } diff --git a/vm/debug.cpp b/vm/debug.cpp index da8c603254..4b47e24221 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -165,23 +165,23 @@ void factor_vm::print_retainstack() } struct stack_frame_printer { - factor_vm *myvm; + factor_vm *parent; - explicit stack_frame_printer(factor_vm *myvm_) : myvm(myvm_) {} + explicit stack_frame_printer(factor_vm *parent_) : parent(parent_) {} void operator()(stack_frame *frame) { - myvm->print_obj(myvm->frame_executing(frame)); + parent->print_obj(parent->frame_executing(frame)); print_string("\n"); - myvm->print_obj(myvm->frame_scan(frame)); + parent->print_obj(parent->frame_scan(frame)); print_string("\n"); print_string("word/quot addr: "); - print_cell_hex((cell)myvm->frame_executing(frame)); + 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,myvm)); + print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,parent)); print_string("\n"); } }; @@ -236,7 +236,7 @@ void factor_vm::dump_objects(cell type) begin_scan(); cell obj; - while((obj = next_object()) != F) + while(to_boolean(obj = next_object())) { if(type == TYPE_COUNT || tagged(obj).type_p(type)) { @@ -252,10 +252,10 @@ void factor_vm::dump_objects(cell type) struct data_references_finder { cell look_for, obj; - factor_vm *myvm; + factor_vm *parent; - explicit data_references_finder(cell look_for_, cell obj_, factor_vm *myvm_) - : look_for(look_for_), obj(obj_), myvm(myvm_) { } + explicit data_references_finder(cell look_for_, cell obj_, factor_vm *parent_) + : look_for(look_for_), obj(obj_), parent(parent_) { } void operator()(cell *scan) { @@ -263,7 +263,7 @@ struct data_references_finder { { print_cell_hex_pad(obj); print_string(" "); - myvm->print_nested_obj(obj,2); + parent->print_nested_obj(obj,2); nl(); } } @@ -275,7 +275,7 @@ void factor_vm::find_data_references(cell look_for) cell obj; - while((obj = next_object()) != F) + while(to_boolean(obj = next_object())) { data_references_finder finder(look_for,obj,this); do_slots(UNTAG(obj),finder); @@ -296,7 +296,7 @@ void factor_vm::dump_code_heap() const char *status; if(scan->type() == FREE_BLOCK_TYPE) status = "free"; - else if(scan->marked_p()) + else if(code->state->is_marked_p(scan)) { reloc_size += object_size(((code_block *)scan)->relocation); literal_size += object_size(((code_block *)scan)->literals); diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index 03323f811d..0abde2e711 100755 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -15,14 +15,14 @@ cell factor_vm::search_lookup_alist(cell table, cell klass) index -= 2; } - return F; + return false_object; } cell factor_vm::search_lookup_hash(cell table, cell klass, cell hashcode) { array *buckets = untag(table); cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); - if(tagged(bucket).type_p(WORD_TYPE) || bucket == F) + if(tagged(bucket).type_p(WORD_TYPE) || !to_boolean(bucket)) return bucket; else return search_lookup_alist(bucket,klass); @@ -56,12 +56,12 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods) if(tagged(echelon_methods).type_p(WORD_TYPE)) return echelon_methods; - else if(echelon_methods != F) + else if(to_boolean(echelon_methods)) { cell klass = nth_superclass(layout,echelon); cell hashcode = untag_fixnum(nth_hashcode(layout,echelon)); cell result = search_lookup_hash(echelon_methods,klass,hashcode); - if(result != F) + if(to_boolean(result)) return result; } @@ -69,7 +69,7 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods) } critical_error("Cannot find tuple method",methods); - return F; + return false_object; } cell factor_vm::lookup_hi_tag_method(cell obj, cell methods) @@ -180,28 +180,28 @@ void factor_vm::primitive_dispatch_stats() void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_) { - gc_root methods(methods_,parent_vm); - gc_root cache(cache_,parent_vm); + gc_root methods(methods_,parent); + gc_root cache(cache_,parent); /* Generate machine code to determine the object's class. */ emit_class_lookup(index,PIC_HI_TAG_TUPLE); /* Do a cache lookup. */ - emit_with(parent_vm->userenv[MEGA_LOOKUP],cache.value()); + emit_with(parent->userenv[MEGA_LOOKUP],cache.value()); /* If we end up here, the cache missed. */ - emit(parent_vm->userenv[JIT_PROLOG]); + emit(parent->userenv[JIT_PROLOG]); /* Push index, method table and cache on the stack. */ push(methods.value()); push(tag_fixnum(index)); push(cache.value()); - word_call(parent_vm->userenv[MEGA_MISS_WORD]); + word_call(parent->userenv[MEGA_MISS_WORD]); /* Now the new method has been stored into the cache, and its on the stack. */ - emit(parent_vm->userenv[JIT_EPILOG]); - emit(parent_vm->userenv[JIT_EXECUTE_JUMP]); + emit(parent->userenv[JIT_EPILOG]); + emit(parent->userenv[JIT_EXECUTE_JUMP]); } } diff --git a/vm/errors.cpp b/vm/errors.cpp index a3c0242d7e..c587fa723a 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -29,7 +29,7 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top) { /* If the error handler is set, we rewind any C stack frames and pass the error to user-space. */ - if(!current_gc && userenv[BREAK_ENV] != F) + if(!current_gc && to_boolean(userenv[BREAK_ENV])) { /* If error was thrown during heap scan, we re-enable the GC */ gc_off = false; @@ -80,7 +80,7 @@ void factor_vm::type_error(cell type, cell tagged) void factor_vm::not_implemented_error() { - general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); + general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object,NULL); } /* Test if 'fault' is in the guard page at the top or bottom (depending on @@ -97,32 +97,32 @@ bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset) void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack) { if(in_page(addr, ds_bot, 0, -1)) - general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); + general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack); else if(in_page(addr, ds_bot, ds_size, 0)) - general_error(ERROR_DS_OVERFLOW,F,F,native_stack); + general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack); else if(in_page(addr, rs_bot, 0, -1)) - general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); + general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack); else if(in_page(addr, rs_bot, rs_size, 0)) - general_error(ERROR_RS_OVERFLOW,F,F,native_stack); + general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack); else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); else - general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); + general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack); } void factor_vm::signal_error(int signal, stack_frame *native_stack) { - general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); + general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack); } void factor_vm::divide_by_zero_error() { - general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); + general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object,NULL); } void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top) { - general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top); + general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,signal_callstack_top); } void factor_vm::primitive_call_clear() diff --git a/vm/factor.cpp b/vm/factor.cpp index 8b1202ddb0..5548ebd610 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -100,7 +100,7 @@ void factor_vm::do_stage1_init() fflush(stdout); compile_all_words(); - userenv[STAGE2_ENV] = T; + userenv[STAGE2_ENV] = true_object; print_string("done\n"); fflush(stdout); @@ -148,17 +148,17 @@ void factor_vm::init_factor(vm_parameters *p) init_profiler(); - userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING); - userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING); + 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(F,(cell)p->executable_path); - userenv[ARGS_ENV] = F; - userenv[EMBEDDED_ENV] = F; + userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path); + userenv[ARGS_ENV] = false_object; + userenv[EMBEDDED_ENV] = false_object; /* We can GC now */ gc_off = false; - if(userenv[STAGE2_ENV] == F) + if(!to_boolean(userenv[STAGE2_ENV])) do_stage1_init(); } @@ -169,7 +169,7 @@ void factor_vm::pass_args_to_factor(int argc, vm_char **argv) int i; for(i = 1; i < argc; i++){ - args.add(allot_alien(F,(cell)argv[i])); + args.add(allot_alien(false_object,(cell)argv[i])); } args.trim(); diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 86f3216e9c..f9db1c8653 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -3,23 +3,23 @@ namespace factor { -full_collector::full_collector(factor_vm *myvm_) : +full_collector::full_collector(factor_vm *parent_) : copying_collector( - myvm_, - &myvm_->gc_stats.full_stats, - myvm_->data->tenured, - full_policy(myvm_)) {} + parent_, + &parent_->gc_stats.full_stats, + parent_->data->tenured, + full_policy(parent_)) {} struct stack_frame_marker { - factor_vm *myvm; + factor_vm *parent; full_collector *collector; explicit stack_frame_marker(full_collector *collector_) : - myvm(collector_->myvm), collector(collector_) {} + parent(collector_->parent), collector(collector_) {} void operator()(stack_frame *frame) { - collector->mark_code_block(myvm->frame_code(frame)); + collector->mark_code_block(parent->frame_code(frame)); } }; @@ -27,7 +27,7 @@ struct stack_frame_marker { void full_collector::mark_active_blocks() { stack_frame_marker marker(this); - myvm->iterate_active_frames(marker); + parent->iterate_active_frames(marker); } void full_collector::mark_object_code_block(object *obj) @@ -54,7 +54,7 @@ void full_collector::mark_object_code_block(object *obj) { callstack *stack = (callstack *)obj; stack_frame_marker marker(this); - myvm->iterate_callstack_object(stack,marker); + parent->iterate_callstack_object(stack,marker); break; } } @@ -74,7 +74,7 @@ struct callback_tracer { void full_collector::trace_callbacks() { callback_tracer tracer(this); - myvm->callbacks->iterate(tracer); + parent->callbacks->iterate(tracer); } /* Trace all literals referenced from a code block. Only for aging and nursery collections */ @@ -100,33 +100,33 @@ void full_collector::cheneys_algorithm() object *obj = (object *)scan; this->trace_slots(obj); this->mark_object_code_block(obj); - scan = target->next_object_after(this->myvm,scan); + 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 *myvm; + factor_vm *parent; - big_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {} + big_code_heap_updater(factor_vm *parent_) : parent(parent_) {} void operator()(heap_block *block) { - myvm->relocate_code_block((code_block *)block); + parent->relocate_code_block((code_block *)block); } }; /* 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 *myvm; + factor_vm *parent; - small_code_heap_updater(factor_vm *myvm_) : myvm(myvm_) {} + small_code_heap_updater(factor_vm *parent_) : parent(parent_) {} void operator()(heap_block *block) { - myvm->update_code_block_for_full_gc((code_block *)block); + parent->update_code_block_for_full_gc((code_block *)block); } }; @@ -134,6 +134,8 @@ void factor_vm::collect_full_impl(bool trace_contexts_p) { full_collector collector(this); + code->state->clear_mark_bits(); + collector.trace_roots(); if(trace_contexts_p) { @@ -148,16 +150,6 @@ void factor_vm::collect_full_impl(bool trace_contexts_p) nursery.here = nursery.start; } -/* In both cases, compact code heap before updating code blocks so that -XTs are correct after */ - -void factor_vm::big_code_heap_update() -{ - big_code_heap_updater updater(this); - code->free_unmarked(updater); - code->clear_remembered_set(); -} - void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p) @@ -168,15 +160,18 @@ void factor_vm::collect_growing_heap(cell requested_bytes, collect_full_impl(trace_contexts_p); delete old; - if(compact_code_heap_p) compact_code_heap(trace_contexts_p); - - big_code_heap_update(); -} + if(compact_code_heap_p) + { + compact_code_heap(trace_contexts_p); + big_code_heap_updater updater(this); + iterate_code_heap(updater); + } + else + { + big_code_heap_updater updater(this); + code->free_unmarked(updater); + } -void factor_vm::small_code_heap_update() -{ - small_code_heap_updater updater(this); - code->free_unmarked(updater); code->clear_remembered_set(); } @@ -190,10 +185,16 @@ void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p) if(compact_code_heap_p) { compact_code_heap(trace_contexts_p); - big_code_heap_update(); + big_code_heap_updater updater(this); + iterate_code_heap(updater); } else - small_code_heap_update(); + { + small_code_heap_updater updater(this); + code->free_unmarked(updater); + } + + code->clear_remembered_set(); } } diff --git a/vm/full_collector.hpp b/vm/full_collector.hpp index c01f1cd486..8cc37f782d 100644 --- a/vm/full_collector.hpp +++ b/vm/full_collector.hpp @@ -2,10 +2,10 @@ namespace factor { struct full_policy { - factor_vm *myvm; + factor_vm *parent; zone *tenured; - full_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {} + full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {} bool should_copy_p(object *untagged) { @@ -16,7 +16,7 @@ struct full_policy { struct full_collector : copying_collector { bool trace_contexts_p; - full_collector(factor_vm *myvm_); + full_collector(factor_vm *parent_); void mark_active_blocks(); void mark_object_code_block(object *object); void trace_callbacks(); diff --git a/vm/gc.cpp b/vm/gc.cpp index c89add6066..c8ba57b7f2 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -54,9 +54,6 @@ void factor_vm::gc(gc_op op, current_gc->op = collect_full_op; break; case collect_full_op: - /* Since we start tracing again, any previously - marked code blocks must be re-marked and re-traced */ - code->clear_mark_bits(); current_gc->op = collect_growing_heap_op; break; default: @@ -205,9 +202,9 @@ void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size) gc_locals.pop_back(); } -VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm) +VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent) { - myvm->inline_gc(gc_roots_base,gc_roots_size); + parent->inline_gc(gc_roots_base,gc_roots_size); } /* diff --git a/vm/gc.hpp b/vm/gc.hpp index 9469603d0c..18b926ed8c 100755 --- a/vm/gc.hpp +++ b/vm/gc.hpp @@ -37,6 +37,6 @@ struct gc_state { ~gc_state(); }; -VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm); +VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent); } diff --git a/vm/heap.cpp b/vm/heap.cpp index 0f0da63df0..71aac62704 100644 --- a/vm/heap.cpp +++ b/vm/heap.cpp @@ -16,9 +16,18 @@ 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(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) @@ -34,52 +43,15 @@ void heap::add_to_free_list(free_heap_block *block) } } -/* Called after reading the code heap from the image file, and after code GC. - -In the former case, we must add a large free block from compiling.base + size to -compiling.limit. */ +/* 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) { - heap_block *prev = NULL; - clear_free_list(); - - size = (size + block_size_increment - 1) & ~(block_size_increment - 1); - - heap_block *scan = first_block(); free_heap_block *end = (free_heap_block *)(seg->start + size); - - /* Add all free blocks to the free list */ - while(scan && scan < (heap_block *)end) - { - if(scan->type() == FREE_BLOCK_TYPE) - add_to_free_list((free_heap_block *)scan); - - prev = scan; - scan = next_block(scan); - } - - /* If there is room at the end of the heap, add a free block. This - branch is only taken after loading a new image, not after code GC */ - if((cell)(end + 1) <= seg->end) - { - end->set_marked_p(false); - end->set_type(FREE_BLOCK_TYPE); - end->set_size(seg->end - (cell)end); - - /* add final free block */ - add_to_free_list(end); - } - /* This branch is taken if the newly loaded image fits exactly, or - after code GC */ - else - { - /* even if there's no room at the end of the heap for a new - free block, we might have to jigger it up by a few bytes in - case prev + prev->size */ - if(prev) prev->set_size(seg->end - (cell)prev); - } - + 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) @@ -154,7 +126,6 @@ heap_block *heap::heap_allot(cell size, cell type) { block = split_free_block(block,size); block->set_type(type); - block->set_marked_p(false); return block; } else @@ -170,18 +141,7 @@ void heap::heap_free(heap_block *block) void heap::mark_block(heap_block *block) { - block->set_marked_p(true); -} - -void heap::clear_mark_bits() -{ - heap_block *scan = first_block(); - - while(scan) - { - scan->set_marked_p(false); - scan = next_block(scan); - } + state->set_marked_p(block,true); } /* Compute total sum of sizes of free blocks, and size of largest free block */ @@ -210,20 +170,21 @@ void heap::heap_usage(cell *used, cell *total_free, cell *max_free) } } -/* The size of the heap, not including the last block if it's free */ +/* The size of the heap after compaction */ cell heap::heap_size() { heap_block *scan = first_block(); + + while(scan) + { + if(scan->type() == FREE_BLOCK_TYPE) break; + else scan = next_block(scan); + } - while(next_block(scan) != NULL) - scan = next_block(scan); + assert(scan->type() == FREE_BLOCK_TYPE); + assert((cell)scan + scan->size() == seg->end); - /* this is the last block in the heap, and it is free */ - if(scan->type() == FREE_BLOCK_TYPE) - return (cell)scan - seg->start; - /* otherwise the last block is allocated */ - else - return seg->size; + return (cell)scan - (cell)first_block(); } void heap::compact_heap() @@ -238,7 +199,7 @@ void heap::compact_heap() { heap_block *next = next_block(scan); - if(scan->type() != FREE_BLOCK_TYPE && scan->marked_p()) + if(state->is_marked_p(scan)) { cell size = scan->size(); memmove(address,scan,size); diff --git a/vm/heap.hpp b/vm/heap.hpp index ef09c2b238..a3c057138b 100644 --- a/vm/heap.hpp +++ b/vm/heap.hpp @@ -1,8 +1,8 @@ namespace factor { -static const cell free_list_count = 16; -static const cell block_size_increment = 32; +static const cell free_list_count = 32; +static const cell block_size_increment = 16; struct heap_free_list { free_heap_block *small_blocks[free_list_count]; @@ -13,9 +13,11 @@ struct heap { bool secure_gc; segment *seg; heap_free_list free; + mark_bits *state; unordered_map forwarding; explicit heap(bool secure_gc_, cell size, bool executable_p); + ~heap(); inline heap_block *next_block(heap_block *block) { @@ -46,7 +48,6 @@ struct heap { heap_block *heap_allot(cell size, cell type); void heap_free(heap_block *block); void mark_block(heap_block *block); - void clear_mark_bits(); void heap_usage(cell *used, cell *total_free, cell *max_free); cell heap_size(); void compact_heap(); @@ -71,11 +72,10 @@ struct heap { else prev = scan; } - else if(scan->marked_p()) + else if(state->is_marked_p(scan)) { if(prev && prev->type() == FREE_BLOCK_TYPE) add_to_free_list((free_heap_block *)prev); - scan->set_marked_p(false); prev = scan; iter(scan); } diff --git a/vm/image.cpp b/vm/image.cpp index 05e0d66724..c6d1ad7aca 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -8,7 +8,7 @@ void factor_vm::init_objects(image_header *h) { memcpy(userenv,h->userenv,sizeof(userenv)); - T = h->t; + true_object = h->true_object; bignum_zero = h->bignum_zero; bignum_pos_one = h->bignum_pos_one; bignum_neg_one = h->bignum_neg_one; @@ -67,86 +67,6 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p) code->build_free_list(h->code_size); } -/* Save the current image to disk */ -bool factor_vm::save_image(const vm_char *filename) -{ - FILE* file; - image_header h; - - file = OPEN_WRITE(filename); - if(file == NULL) - { - print_string("Cannot open image file: "); print_native_string(filename); nl(); - print_string(strerror(errno)); nl(); - 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.code_relocation_base = code->seg->start; - h.code_size = code->heap_size(); - - h.t = T; - 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] : F); - - 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(fclose(file)) ok = false; - - if(!ok) - { - print_string("save-image failed: "); print_string(strerror(errno)); nl(); - } - - return ok; -} - -void factor_vm::primitive_save_image() -{ - /* do a full GC to push everything into tenured space */ - primitive_compact_gc(); - - gc_root path(dpop(),this); - path.untag_check(this); - save_image((vm_char *)(path.untagged() + 1)); -} - -void factor_vm::primitive_save_image_and_exit() -{ - /* We unbox this before doing anything else. This is the only point - where we might throw an error, so we have to throw an error here since - later steps destroy the current image. */ - gc_root 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] = F; - } - - gc(collect_full_op, - 0, /* requested size */ - false, /* discard objects only reachable from stacks */ - true /* compact the code heap */); - - /* Save the image */ - if(save_image((vm_char *)(path.untagged() + 1))) - exit(0); - else - exit(1); -} - void factor_vm::data_fixup(cell *handle, cell data_relocation_base) { if(immediate_p(*handle)) @@ -184,19 +104,19 @@ void factor_vm::fixup_quotation(quotation *quot, cell code_relocation_base) void factor_vm::fixup_alien(alien *d) { - if(d->base == F) d->expired = T; + if(!to_boolean(d->base)) d->expired = true_object; } struct stack_frame_fixupper { - factor_vm *myvm; + factor_vm *parent; cell code_relocation_base; - explicit stack_frame_fixupper(factor_vm *myvm_, cell code_relocation_base_) : - myvm(myvm_), code_relocation_base(code_relocation_base_) {} + explicit stack_frame_fixupper(factor_vm *parent_, cell code_relocation_base_) : + parent(parent_), code_relocation_base(code_relocation_base_) {} void operator()(stack_frame *frame) { - myvm->code_fixup(&frame->xt,code_relocation_base); - myvm->code_fixup(&FRAME_RETURN_ADDRESS(frame,myvm),code_relocation_base); + parent->code_fixup(&frame->xt,code_relocation_base); + parent->code_fixup(&FRAME_RETURN_ADDRESS(frame,parent),code_relocation_base); } }; @@ -207,15 +127,15 @@ void factor_vm::fixup_callstack_object(callstack *stack, cell code_relocation_ba } struct object_fixupper { - factor_vm *myvm; + factor_vm *parent; cell data_relocation_base; - explicit object_fixupper(factor_vm *myvm_, cell data_relocation_base_) : - myvm(myvm_), data_relocation_base(data_relocation_base_) { } + explicit object_fixupper(factor_vm *parent_, cell data_relocation_base_) : + parent(parent_), data_relocation_base(data_relocation_base_) { } void operator()(cell *scan) { - myvm->data_fixup(scan,data_relocation_base); + parent->data_fixup(scan,data_relocation_base); } }; @@ -273,7 +193,7 @@ void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_ba for(cell i = 0; i < USER_ENV; i++) data_fixup(&userenv[i],data_relocation_base); - data_fixup(&T,data_relocation_base); + data_fixup(&true_object,data_relocation_base); data_fixup(&bignum_zero,data_relocation_base); data_fixup(&bignum_pos_one,data_relocation_base); data_fixup(&bignum_neg_one,data_relocation_base); @@ -299,15 +219,15 @@ void factor_vm::fixup_code_block(code_block *compiled, cell data_relocation_base } struct code_block_fixupper { - factor_vm *myvm; + factor_vm *parent; cell data_relocation_base; - code_block_fixupper(factor_vm *myvm_, cell data_relocation_base_) : - myvm(myvm_), data_relocation_base(data_relocation_base_) { } + code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) : + parent(parent_), data_relocation_base(data_relocation_base_) { } void operator()(code_block *compiled) { - myvm->fixup_code_block(compiled,data_relocation_base); + parent->fixup_code_block(compiled,data_relocation_base); } }; @@ -350,7 +270,85 @@ void factor_vm::load_image(vm_parameters *p) relocate_code(h.data_relocation_base); /* Store image path name */ - userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path); + userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path); +} + +/* Save the current image to disk */ +bool factor_vm::save_image(const vm_char *filename) +{ + FILE* file; + image_header h; + + file = OPEN_WRITE(filename); + if(file == NULL) + { + print_string("Cannot open image file: "); print_native_string(filename); nl(); + print_string(strerror(errno)); nl(); + 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.code_relocation_base = code->seg->start; + h.code_size = code->heap_size(); + + 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); + + 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(fclose(file)) ok = false; + + if(!ok) + { + print_string("save-image failed: "); print_string(strerror(errno)); nl(); + } + + return ok; +} + +void factor_vm::primitive_save_image() +{ + /* do a full GC to push everything into tenured space */ + primitive_compact_gc(); + + gc_root path(dpop(),this); + path.untag_check(this); + save_image((vm_char *)(path.untagged() + 1)); +} + +void factor_vm::primitive_save_image_and_exit() +{ + /* We unbox this before doing anything else. This is the only point + where we might throw an error, so we have to throw an error here since + later steps destroy the current image. */ + gc_root 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; + + gc(collect_full_op, + 0, /* requested size */ + false, /* discard objects only reachable from stacks */ + true /* compact the code heap */); + + /* Save the image */ + if(save_image((vm_char *)(path.untagged() + 1))) + exit(0); + else + exit(1); } } diff --git a/vm/image.hpp b/vm/image.hpp index f071185852..8a7080110c 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -17,7 +17,7 @@ struct image_header { /* size of code heap */ cell code_size; /* tagged pointer to t singleton */ - cell t; + cell true_object; /* tagged pointer to bignum 0 */ cell bignum_zero; /* tagged pointer to bignum 1 */ diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 7f7471ad1f..f6e756f758 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -92,9 +92,9 @@ void inline_cache_jit::emit_check(cell klass) { cell code_template; if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE) - code_template = parent_vm->userenv[PIC_CHECK_TAG]; + code_template = parent->userenv[PIC_CHECK_TAG]; else - code_template = parent_vm->userenv[PIC_CHECK]; + code_template = parent->userenv[PIC_CHECK]; emit_with(code_template,klass); } @@ -107,12 +107,12 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell cache_entries_, bool tail_call_p) { - gc_root generic_word(generic_word_,parent_vm); - gc_root methods(methods_,parent_vm); - gc_root cache_entries(cache_entries_,parent_vm); + gc_root generic_word(generic_word_,parent); + gc_root methods(methods_,parent); + gc_root cache_entries(cache_entries_,parent); - cell inline_cache_type = parent_vm->determine_inline_cache_type(cache_entries.untagged()); - parent_vm->update_pic_count(inline_cache_type); + cell inline_cache_type = parent->determine_inline_cache_type(cache_entries.untagged()); + parent->update_pic_count(inline_cache_type); /* Generate machine code to determine the object's class. */ emit_class_lookup(index,inline_cache_type); @@ -127,7 +127,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index, /* Yes? Jump to method */ cell method = array_nth(cache_entries.untagged(),i + 1); - emit_with(parent_vm->userenv[PIC_HIT],method); + emit_with(parent->userenv[PIC_HIT],method); } /* Generate machine code to handle a cache miss, which ultimately results in @@ -139,7 +139,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index, push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_special(parent_vm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); + word_special(parent->userenv[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) @@ -248,9 +248,9 @@ void *factor_vm::inline_cache_miss(cell return_address) return xt; } -VM_C_API void *inline_cache_miss(cell return_address, factor_vm *myvm) +VM_C_API void *inline_cache_miss(cell return_address, factor_vm *parent) { - return myvm->inline_cache_miss(return_address); + return parent->inline_cache_miss(return_address); } void factor_vm::primitive_reset_inline_cache_stats() diff --git a/vm/io.cpp b/vm/io.cpp index 8e6eff730e..d5cfc1745c 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -16,9 +16,9 @@ normal operation. */ void factor_vm::init_c_io() { - userenv[STDIN_ENV] = allot_alien(F,(cell)stdin); - userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout); - userenv[STDERR_ENV] = allot_alien(F,(cell)stderr); + 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); } void factor_vm::io_error() @@ -28,7 +28,7 @@ void factor_vm::io_error() return; #endif - general_error(ERROR_IO,tag_fixnum(errno),F,NULL); + general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL); } void factor_vm::primitive_fopen() @@ -63,7 +63,7 @@ void factor_vm::primitive_fgetc() { if(feof(file)) { - dpush(F); + dpush(false_object); break; } else @@ -97,7 +97,7 @@ void factor_vm::primitive_fread() { if(feof(file)) { - dpush(F); + dpush(false_object); break; } else diff --git a/vm/jit.cpp b/vm/jit.cpp index 77a311cb24..ced487e659 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -19,12 +19,12 @@ jit::jit(cell type_, cell owner_, factor_vm *vm) computing_offset_p(false), position(0), offset(0), - parent_vm(vm) + parent(vm) {} void jit::emit_relocation(cell code_template_) { - gc_root code_template(code_template_,parent_vm); + gc_root code_template(code_template_,parent); cell capacity = array_capacity(code_template.untagged()); for(cell i = 1; i < capacity; i += 3) { @@ -43,11 +43,11 @@ void jit::emit_relocation(cell code_template_) /* Allocates memory */ void jit::emit(cell code_template_) { - gc_root code_template(code_template_,parent_vm); + gc_root code_template(code_template_,parent); emit_relocation(code_template.value()); - gc_root insns(array_nth(code_template.untagged(),0),parent_vm); + gc_root insns(array_nth(code_template.untagged(),0),parent); if(computing_offset_p) { @@ -71,16 +71,16 @@ void jit::emit(cell code_template_) } void jit::emit_with(cell code_template_, cell argument_) { - gc_root code_template(code_template_,parent_vm); - gc_root argument(argument_,parent_vm); + gc_root code_template(code_template_,parent); + gc_root argument(argument_,parent); literal(argument.value()); emit(code_template.value()); } void jit::emit_class_lookup(fixnum index, cell type) { - emit_with(parent_vm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell))); - emit(parent_vm->userenv[type]); + emit_with(parent->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell))); + emit(parent->userenv[type]); } /* Facility to convert compiled code offsets to quotation offsets. @@ -100,10 +100,10 @@ code_block *jit::to_code_block() relocation.trim(); literals.trim(); - return parent_vm->add_code_block( + return parent->add_code_block( type, code.elements.value(), - F, /* no labels */ + false_object, /* no labels */ owner.value(), relocation.elements.value(), literals.elements.value()); diff --git a/vm/jit.hpp b/vm/jit.hpp index 63b4454514..d69f44d05d 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -10,7 +10,7 @@ struct jit { bool computing_offset_p; fixnum position; cell offset; - factor_vm *parent_vm; + factor_vm *parent; explicit jit(cell jit_type, cell owner, factor_vm *vm); void compute_position(cell offset); @@ -22,27 +22,28 @@ struct jit { void emit_with(cell code_template_, cell literal_); void push(cell literal) { - emit_with(parent_vm->userenv[JIT_PUSH_IMMEDIATE],literal); + emit_with(parent->userenv[JIT_PUSH_IMMEDIATE],literal); } - void word_jump(cell word) { + void word_jump(cell word_) { + gc_root word(word_,parent); literal(tag_fixnum(xt_tail_pic_offset)); - literal(word); - emit(parent_vm->userenv[JIT_WORD_JUMP]); + literal(word.value()); + emit(parent->userenv[JIT_WORD_JUMP]); } void word_call(cell word) { - emit_with(parent_vm->userenv[JIT_WORD_CALL],word); + emit_with(parent->userenv[JIT_WORD_CALL],word); } void word_special(cell word) { - emit_with(parent_vm->userenv[JIT_WORD_SPECIAL],word); + emit_with(parent->userenv[JIT_WORD_SPECIAL],word); } void emit_subprimitive(cell word_) { - gc_root word(word_,parent_vm); - gc_root code_pair(word->subprimitive,parent_vm); - literals.append(parent_vm->untag(array_nth(code_pair.untagged(),0))); + gc_root word(word_,parent); + gc_root code_pair(word->subprimitive,parent); + literals.append(parent->untag(array_nth(code_pair.untagged(),0))); emit(array_nth(code_pair.untagged(),1)); } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 2fba97d747..34dbe163f9 100644 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -46,9 +46,6 @@ inline static cell align8(cell a) #define OBJECT_TYPE 6 #define TUPLE_TYPE 7 -/* Canonical F object */ -#define F F_TYPE - #define HEADER_TYPE 8 /* anything less than this is a tag */ #define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */ @@ -78,9 +75,12 @@ enum FP_TRAP_INEXACT = 1 << 4, }; +/* What Factor calls 'f' */ +static const cell false_object = F_TYPE; + inline static bool immediate_p(cell obj) { - return (obj == F || TAG(obj) == FIXNUM_TYPE); + return (obj == false_object || TAG(obj) == FIXNUM_TYPE); } inline static fixnum untag_fixnum(cell tagged) @@ -201,15 +201,6 @@ struct heap_block { cell header; - bool marked_p() { return header & 1; } - void set_marked_p(bool marked) - { - if(marked) - header |= 1; - else - header &= ~1; - } - cell type() { return (header >> 1) & 0x1f; } void set_type(cell type) { diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index 7becc906a0..6ae059f4c4 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -4,21 +4,21 @@ namespace factor template struct gc_root : public tagged { - factor_vm *parent_vm; + factor_vm *parent; - void push() { parent_vm->check_tagged_pointer(tagged::value()); parent_vm->gc_locals.push_back((cell)this); } + void push() { parent->check_tagged_pointer(tagged::value()); parent->gc_locals.push_back((cell)this); } - explicit gc_root(cell value_,factor_vm *vm) : tagged(value_),parent_vm(vm) { push(); } - explicit gc_root(Type *value_, factor_vm *vm) : tagged(value_),parent_vm(vm) { push(); } + explicit gc_root(cell value_,factor_vm *vm) : tagged(value_),parent(vm) { push(); } + explicit gc_root(Type *value_, factor_vm *vm) : tagged(value_),parent(vm) { push(); } const gc_root& operator=(const Type *x) { tagged::operator=(x); return *this; } const gc_root& operator=(const cell &x) { tagged::operator=(x); return *this; } ~gc_root() { #ifdef FACTOR_DEBUG - assert(parent_vm->gc_locals.back() == (cell)this); + assert(parent->gc_locals.back() == (cell)this); #endif - parent_vm->gc_locals.pop_back(); + parent->gc_locals.pop_back(); } }; @@ -26,18 +26,18 @@ struct gc_root : public tagged struct gc_bignum { bignum **addr; - factor_vm *parent_vm; - gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent_vm(vm) { + factor_vm *parent; + gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent(vm) { if(*addr_) - parent_vm->check_data_pointer(*addr_); - parent_vm->gc_bignums.push_back((cell)addr); + parent->check_data_pointer(*addr_); + parent->gc_bignums.push_back((cell)addr); } ~gc_bignum() { #ifdef FACTOR_DEBUG - assert(parent_vm->gc_bignums.back() == (cell)addr); + assert(parent->gc_bignums.back() == (cell)addr); #endif - parent_vm->gc_bignums.pop_back(); + parent->gc_bignums.pop_back(); } }; diff --git a/vm/mark_bits.hpp b/vm/mark_bits.hpp new file mode 100644 index 0000000000..7945be1850 --- /dev/null +++ b/vm/mark_bits.hpp @@ -0,0 +1,103 @@ +namespace factor +{ + +const int forwarding_granularity = 128; + +template struct mark_bits { + cell start; + cell size; + cell bits_size; + unsigned int *marked; + unsigned int *freed; + cell forwarding_size; + cell *forwarding; + + void clear_mark_bits() + { + memset(marked,0,bits_size * sizeof(unsigned int)); + } + + void clear_free_bits() + { + memset(freed,0,bits_size * sizeof(unsigned int)); + } + + void clear_forwarding() + { + memset(forwarding,0,forwarding_size * sizeof(cell)); + } + + explicit mark_bits(cell start_, cell size_) : + start(start_), + size(size_), + bits_size(size / Granularity / 32), + marked(new unsigned int[bits_size]), + freed(new unsigned int[bits_size]), + forwarding_size(size / Granularity / forwarding_granularity), + forwarding(new cell[forwarding_size]) + { + clear_mark_bits(); + clear_free_bits(); + clear_forwarding(); + } + + ~mark_bits() + { + delete[] marked; + marked = NULL; + delete[] freed; + freed = NULL; + delete[] forwarding; + forwarding = NULL; + } + + std::pair bitmap_deref(Block *address) + { + cell word_number = (((cell)address - start) / Granularity); + cell word_index = (word_number >> 5); + cell word_shift = (word_number & 31); + +#ifdef FACTOR_DEBUG + assert(word_index < bits_size); +#endif + + return std::make_pair(word_index,word_shift); + } + + bool bitmap_elt(unsigned int *bits, Block *address) + { + std::pair pair = bitmap_deref(address); + return (bits[pair.first] & (1 << pair.second)) != 0; + } + + void set_bitmap_elt(unsigned int *bits, Block *address, bool flag) + { + std::pair pair = bitmap_deref(address); + if(flag) + bits[pair.first] |= (1 << pair.second); + else + bits[pair.first] &= ~(1 << pair.second); + } + + bool is_marked_p(Block *address) + { + return bitmap_elt(marked,address); + } + + void set_marked_p(Block *address, bool marked_p) + { + set_bitmap_elt(marked,address,marked_p); + } + + bool is_free_p(Block *address) + { + return bitmap_elt(freed,address); + } + + void set_free_p(Block *address, bool free_p) + { + set_bitmap_elt(freed,address,free_p); + } +}; + +} diff --git a/vm/master.hpp b/vm/master.hpp index c5aed5e983..847980fac6 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -78,6 +78,7 @@ namespace factor #include "words.hpp" #include "float_bits.hpp" #include "io.hpp" +#include "mark_bits.hpp" #include "heap.hpp" #include "image.hpp" #include "alien.hpp" diff --git a/vm/math.cpp b/vm/math.cpp index e4caa0f5ca..169790d365 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -219,9 +219,9 @@ unsigned int factor_vm::bignum_producer(unsigned int digit) return *(ptr + digit); } -unsigned int bignum_producer(unsigned int digit, factor_vm *myvm) +unsigned int bignum_producer(unsigned int digit, factor_vm *parent) { - return myvm->bignum_producer(digit); + return parent->bignum_producer(digit); } void factor_vm::primitive_byte_array_to_bignum() @@ -285,7 +285,7 @@ void factor_vm::primitive_str_to_float() if(end == c_str + capacity - 1) drepl(allot_float(f)); else - drepl(F); + drepl(false_object); } void factor_vm::primitive_float_to_str() @@ -393,9 +393,9 @@ fixnum factor_vm::to_fixnum(cell tagged) } } -VM_C_API fixnum to_fixnum(cell tagged,factor_vm *myvm) +VM_C_API fixnum to_fixnum(cell tagged,factor_vm *parent) { - return myvm->to_fixnum(tagged); + return parent->to_fixnum(tagged); } cell factor_vm::to_cell(cell tagged) @@ -403,9 +403,9 @@ cell factor_vm::to_cell(cell tagged) return (cell)to_fixnum(tagged); } -VM_C_API cell to_cell(cell tagged, factor_vm *myvm) +VM_C_API cell to_cell(cell tagged, factor_vm *parent) { - return myvm->to_cell(tagged); + return parent->to_cell(tagged); } void factor_vm::box_signed_1(s8 n) @@ -413,9 +413,9 @@ void factor_vm::box_signed_1(s8 n) dpush(tag_fixnum(n)); } -VM_C_API void box_signed_1(s8 n,factor_vm *myvm) +VM_C_API void box_signed_1(s8 n,factor_vm *parent) { - return myvm->box_signed_1(n); + return parent->box_signed_1(n); } void factor_vm::box_unsigned_1(u8 n) @@ -423,9 +423,9 @@ void factor_vm::box_unsigned_1(u8 n) dpush(tag_fixnum(n)); } -VM_C_API void box_unsigned_1(u8 n,factor_vm *myvm) +VM_C_API void box_unsigned_1(u8 n,factor_vm *parent) { - return myvm->box_unsigned_1(n); + return parent->box_unsigned_1(n); } void factor_vm::box_signed_2(s16 n) @@ -433,9 +433,9 @@ void factor_vm::box_signed_2(s16 n) dpush(tag_fixnum(n)); } -VM_C_API void box_signed_2(s16 n,factor_vm *myvm) +VM_C_API void box_signed_2(s16 n,factor_vm *parent) { - return myvm->box_signed_2(n); + return parent->box_signed_2(n); } void factor_vm::box_unsigned_2(u16 n) @@ -443,9 +443,9 @@ void factor_vm::box_unsigned_2(u16 n) dpush(tag_fixnum(n)); } -VM_C_API void box_unsigned_2(u16 n,factor_vm *myvm) +VM_C_API void box_unsigned_2(u16 n,factor_vm *parent) { - return myvm->box_unsigned_2(n); + return parent->box_unsigned_2(n); } void factor_vm::box_signed_4(s32 n) @@ -453,9 +453,9 @@ void factor_vm::box_signed_4(s32 n) dpush(allot_integer(n)); } -VM_C_API void box_signed_4(s32 n,factor_vm *myvm) +VM_C_API void box_signed_4(s32 n,factor_vm *parent) { - return myvm->box_signed_4(n); + return parent->box_signed_4(n); } void factor_vm::box_unsigned_4(u32 n) @@ -463,9 +463,9 @@ void factor_vm::box_unsigned_4(u32 n) dpush(allot_cell(n)); } -VM_C_API void box_unsigned_4(u32 n,factor_vm *myvm) +VM_C_API void box_unsigned_4(u32 n,factor_vm *parent) { - return myvm->box_unsigned_4(n); + return parent->box_unsigned_4(n); } void factor_vm::box_signed_cell(fixnum integer) @@ -473,9 +473,9 @@ void factor_vm::box_signed_cell(fixnum integer) dpush(allot_integer(integer)); } -VM_C_API void box_signed_cell(fixnum integer,factor_vm *myvm) +VM_C_API void box_signed_cell(fixnum integer,factor_vm *parent) { - return myvm->box_signed_cell(integer); + return parent->box_signed_cell(integer); } void factor_vm::box_unsigned_cell(cell cell) @@ -483,9 +483,9 @@ void factor_vm::box_unsigned_cell(cell cell) dpush(allot_cell(cell)); } -VM_C_API void box_unsigned_cell(cell cell,factor_vm *myvm) +VM_C_API void box_unsigned_cell(cell cell,factor_vm *parent) { - return myvm->box_unsigned_cell(cell); + return parent->box_unsigned_cell(cell); } void factor_vm::box_signed_8(s64 n) @@ -496,9 +496,9 @@ void factor_vm::box_signed_8(s64 n) dpush(tag_fixnum(n)); } -VM_C_API void box_signed_8(s64 n,factor_vm *myvm) +VM_C_API void box_signed_8(s64 n,factor_vm *parent) { - return myvm->box_signed_8(n); + return parent->box_signed_8(n); } s64 factor_vm::to_signed_8(cell obj) @@ -515,9 +515,9 @@ s64 factor_vm::to_signed_8(cell obj) } } -VM_C_API s64 to_signed_8(cell obj,factor_vm *myvm) +VM_C_API s64 to_signed_8(cell obj,factor_vm *parent) { - return myvm->to_signed_8(obj); + return parent->to_signed_8(obj); } void factor_vm::box_unsigned_8(u64 n) @@ -528,9 +528,9 @@ void factor_vm::box_unsigned_8(u64 n) dpush(tag_fixnum(n)); } -VM_C_API void box_unsigned_8(u64 n,factor_vm *myvm) +VM_C_API void box_unsigned_8(u64 n,factor_vm *parent) { - return myvm->box_unsigned_8(n); + return parent->box_unsigned_8(n); } u64 factor_vm::to_unsigned_8(cell obj) @@ -547,9 +547,9 @@ u64 factor_vm::to_unsigned_8(cell obj) } } -VM_C_API u64 to_unsigned_8(cell obj,factor_vm *myvm) +VM_C_API u64 to_unsigned_8(cell obj,factor_vm *parent) { - return myvm->to_unsigned_8(obj); + return parent->to_unsigned_8(obj); } void factor_vm::box_float(float flo) @@ -557,9 +557,9 @@ void factor_vm::box_float(float flo) dpush(allot_float(flo)); } -VM_C_API void box_float(float flo, factor_vm *myvm) +VM_C_API void box_float(float flo, factor_vm *parent) { - return myvm->box_float(flo); + return parent->box_float(flo); } float factor_vm::to_float(cell value) @@ -567,9 +567,9 @@ float factor_vm::to_float(cell value) return untag_float_check(value); } -VM_C_API float to_float(cell value,factor_vm *myvm) +VM_C_API float to_float(cell value,factor_vm *parent) { - return myvm->to_float(value); + return parent->to_float(value); } void factor_vm::box_double(double flo) @@ -577,9 +577,9 @@ void factor_vm::box_double(double flo) dpush(allot_float(flo)); } -VM_C_API void box_double(double flo,factor_vm *myvm) +VM_C_API void box_double(double flo,factor_vm *parent) { - return myvm->box_double(flo); + return parent->box_double(flo); } double factor_vm::to_double(cell value) @@ -587,9 +587,9 @@ double factor_vm::to_double(cell value) return untag_float_check(value); } -VM_C_API double to_double(cell value,factor_vm *myvm) +VM_C_API double to_double(cell value,factor_vm *parent) { - return myvm->to_double(value); + return parent->to_double(value); } /* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On @@ -600,9 +600,9 @@ inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y) untag_fixnum(x) + untag_fixnum(y)))); } -VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm) +VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *parent) { - ((factor_vm*)myvm)->overflow_fixnum_add(x,y); + parent->overflow_fixnum_add(x,y); } inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y) @@ -611,9 +611,9 @@ inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y) untag_fixnum(x) - untag_fixnum(y)))); } -VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm) +VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *parent) { - ((factor_vm*)myvm)->overflow_fixnum_subtract(x,y); + parent->overflow_fixnum_subtract(x,y); } inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y) @@ -625,9 +625,9 @@ inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y) drepl(tag(bignum_multiply(bx,by))); } -VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm) +VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *parent) { - ((factor_vm*)myvm)->overflow_fixnum_multiply(x,y); + parent->overflow_fixnum_multiply(x,y); } } diff --git a/vm/nursery_collector.cpp b/vm/nursery_collector.cpp index 6eb6d840f1..909cde02f8 100644 --- a/vm/nursery_collector.cpp +++ b/vm/nursery_collector.cpp @@ -3,12 +3,12 @@ namespace factor { -nursery_collector::nursery_collector(factor_vm *myvm_) : +nursery_collector::nursery_collector(factor_vm *parent_) : copying_collector( - myvm_, - &myvm_->gc_stats.nursery_stats, - myvm_->data->aging, - nursery_policy(myvm_)) {} + parent_, + &parent_->gc_stats.nursery_stats, + parent_->data->aging, + nursery_policy(parent_)) {} void factor_vm::collect_nursery() { diff --git a/vm/nursery_collector.hpp b/vm/nursery_collector.hpp index cff988cf9d..f9d2172929 100644 --- a/vm/nursery_collector.hpp +++ b/vm/nursery_collector.hpp @@ -2,18 +2,18 @@ namespace factor { struct nursery_policy { - factor_vm *myvm; + factor_vm *parent; - nursery_policy(factor_vm *myvm_) : myvm(myvm_) {} + nursery_policy(factor_vm *parent_) : parent(parent_) {} bool should_copy_p(object *untagged) { - return myvm->nursery.contains_p(untagged); + return parent->nursery.contains_p(untagged); } }; struct nursery_collector : copying_collector { - nursery_collector(factor_vm *myvm_); + nursery_collector(factor_vm *parent_); }; } diff --git a/vm/old_space.cpp b/vm/old_space.cpp index 06e13a77ba..5fd78a7cf4 100644 --- a/vm/old_space.cpp +++ b/vm/old_space.cpp @@ -62,9 +62,9 @@ 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 *myvm, cell scan) +cell old_space::next_object_after(factor_vm *parent, cell scan) { - cell size = myvm->untagged_object_size((object *)scan); + cell size = parent->untagged_object_size((object *)scan); if(scan + size < here) return scan + size; else diff --git a/vm/old_space.hpp b/vm/old_space.hpp index fff98e9343..d037a039ae 100644 --- a/vm/old_space.hpp +++ b/vm/old_space.hpp @@ -15,7 +15,7 @@ struct old_space : zone { void record_object_start_offset(object *obj); object *allot(cell size); void clear_object_start_offsets(); - cell next_object_after(factor_vm *myvm, cell scan); + cell next_object_after(factor_vm *parent, cell scan); }; } diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index 2bd313e1c0..ffc5a6097a 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -45,19 +45,19 @@ VM_C_API int inotify_rm_watch(int fd, u32 wd) VM_C_API int inotify_init() { - myvm->not_implemented_error(); + parent->not_implemented_error(); return -1; } VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask) { - myvm->not_implemented_error(); + parent->not_implemented_error(); return -1; } VM_C_API int inotify_rm_watch(int fd, u32 wd) { - myvm->not_implemented_error(); + parent->not_implemented_error(); return -1; } diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index 3aa001774b..96f169bbcf 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -13,7 +13,7 @@ NS_DURING c_to_factor(quot,this); NS_VOIDRETURN; NS_HANDLER - dpush(allot_alien(F,(cell)localException)); + dpush(allot_alien(false_object,(cell)localException)); quot = userenv[COCOA_EXCEPTION_ENV]; if(!tagged(quot).type_p(QUOTATION_TYPE)) { diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 70d7e395de..2f9d5a3c89 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -72,7 +72,7 @@ void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol) void factor_vm::ffi_dlclose(dll *dll) { if(dlclose(dll->dll)) - general_error(ERROR_FFI,F,F,NULL); + general_error(ERROR_FFI,false_object,false_object,NULL); dll->dll = NULL; } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 467eef473e..8e4efd8d14 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -2,18 +2,18 @@ namespace factor { #if defined(FACTOR_X86) - extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm); - #define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) - #define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) \ - { \ - ((factor_vm*)myvm)->primitive_##name(); \ + extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(factor_vm *parent); + #define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(factor_vm *parent) + #define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(factor_vm *parent) \ + { \ + parent->primitive_##name(); \ } #else - extern "C" typedef void (*primitive_type)(void *myvm); - #define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm) - #define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(void *myvm) \ - { \ - ((factor_vm*)myvm)->primitive_##name(); \ + extern "C" typedef void (*primitive_type)(factor_vm *parent); + #define PRIMITIVE(name) extern "C" void primitive_##name(factor_vm *parent) + #define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(factor_vm *parent) \ + { \ + parent->primitive_##name(); \ } #endif extern const primitive_type primitives[]; diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 60fdce1003..9c2c85215d 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -38,29 +38,29 @@ so this results in a big speedup for relatively little effort. */ bool quotation_jit::primitive_call_p(cell i, cell length) { - return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD]; + return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_PRIMITIVE_WORD]; } bool quotation_jit::fast_if_p(cell i, cell length) { return (i + 3) == length && tagged(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE) - && array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD]; + && array_nth(elements.untagged(),i + 2) == parent->userenv[JIT_IF_WORD]; } bool quotation_jit::fast_dip_p(cell i, cell length) { - return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD]; + return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DIP_WORD]; } bool quotation_jit::fast_2dip_p(cell i, cell length) { - return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD]; + return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_2DIP_WORD]; } bool quotation_jit::fast_3dip_p(cell i, cell length) { - return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD]; + return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_3DIP_WORD]; } bool quotation_jit::mega_lookup_p(cell i, cell length) @@ -68,13 +68,13 @@ bool quotation_jit::mega_lookup_p(cell i, cell length) return (i + 4) <= length && tagged(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE) && tagged(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE) - && array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD]; + && array_nth(elements.untagged(),i + 3) == parent->userenv[MEGA_LOOKUP_WORD]; } bool quotation_jit::declare_p(cell i, cell length) { return (i + 2) <= length - && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DECLARE_WORD]; + && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DECLARE_WORD]; } bool quotation_jit::stack_frame_p() @@ -88,7 +88,7 @@ bool quotation_jit::stack_frame_p() switch(tagged(obj).type()) { case WORD_TYPE: - if(parent_vm->untag(obj)->subprimitive == F) + if(!parent->to_boolean(parent->untag(obj)->subprimitive)) return true; break; case QUOTATION_TYPE: @@ -110,9 +110,9 @@ bool quotation_jit::trivial_quotation_p(array *elements) void quotation_jit::emit_quot(cell quot_) { - gc_root quot(quot_,parent_vm); + gc_root quot(quot_,parent); - array *elements = parent_vm->untag(quot->array); + array *elements = parent->untag(quot->array); /* If the quotation consists of a single word, compile a direct call to the word. */ @@ -120,7 +120,7 @@ void quotation_jit::emit_quot(cell quot_) literal(array_nth(elements,0)); else { - if(compiling) parent_vm->jit_compile(quot.value(),relocate); + if(compiling) parent->jit_compile(quot.value(),relocate); literal(quot.value()); } } @@ -133,7 +133,7 @@ void quotation_jit::iterate_quotation() set_position(0); if(stack_frame) - emit(parent_vm->userenv[JIT_PROLOG]); + emit(parent->userenv[JIT_PROLOG]); cell i; cell length = array_capacity(elements.untagged()); @@ -143,32 +143,32 @@ void quotation_jit::iterate_quotation() { set_position(i); - gc_root obj(array_nth(elements.untagged(),i),parent_vm); + gc_root obj(array_nth(elements.untagged(),i),parent); switch(obj.type()) { case WORD_TYPE: /* Intrinsics */ - if(obj.as()->subprimitive != F) + if(parent->to_boolean(obj.as()->subprimitive)) emit_subprimitive(obj.value()); /* The (execute) primitive is special-cased */ - else if(obj.value() == parent_vm->userenv[JIT_EXECUTE_WORD]) + else if(obj.value() == parent->userenv[JIT_EXECUTE_WORD]) { if(i == length - 1) { - if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]); + if(stack_frame) emit(parent->userenv[JIT_EPILOG]); tail_call = true; - emit(parent_vm->userenv[JIT_EXECUTE_JUMP]); + emit(parent->userenv[JIT_EXECUTE_JUMP]); } else - emit(parent_vm->userenv[JIT_EXECUTE_CALL]); + emit(parent->userenv[JIT_EXECUTE_CALL]); } /* Everything else */ else { if(i == length - 1) { - if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]); + if(stack_frame) emit(parent->userenv[JIT_EPILOG]); tail_call = true; /* Inline cache misses are special-cased. The calling convention for tail @@ -178,8 +178,8 @@ void quotation_jit::iterate_quotation() the inline cache miss primitive, and we don't want to clobber the saved address. */ - if(obj.value() == parent_vm->userenv[PIC_MISS_WORD] - || obj.value() == parent_vm->userenv[PIC_MISS_TAIL_WORD]) + if(obj.value() == parent->userenv[PIC_MISS_WORD] + || obj.value() == parent->userenv[PIC_MISS_TAIL_WORD]) { word_special(obj.value()); } @@ -201,7 +201,7 @@ void quotation_jit::iterate_quotation() { literal(tag_fixnum(0)); literal(obj.value()); - emit(parent_vm->userenv[JIT_PRIMITIVE]); + emit(parent->userenv[JIT_PRIMITIVE]); i++; @@ -215,12 +215,12 @@ void quotation_jit::iterate_quotation() mutually recursive in the library, but both still work) */ if(fast_if_p(i,length)) { - if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]); + if(stack_frame) emit(parent->userenv[JIT_EPILOG]); tail_call = true; emit_quot(array_nth(elements.untagged(),i)); emit_quot(array_nth(elements.untagged(),i + 1)); - emit(parent_vm->userenv[JIT_IF]); + emit(parent->userenv[JIT_IF]); i += 2; } @@ -228,21 +228,21 @@ void quotation_jit::iterate_quotation() else if(fast_dip_p(i,length)) { emit_quot(obj.value()); - emit(parent_vm->userenv[JIT_DIP]); + emit(parent->userenv[JIT_DIP]); i++; } /* 2dip */ else if(fast_2dip_p(i,length)) { emit_quot(obj.value()); - emit(parent_vm->userenv[JIT_2DIP]); + emit(parent->userenv[JIT_2DIP]); i++; } /* 3dip */ else if(fast_3dip_p(i,length)) { emit_quot(obj.value()); - emit(parent_vm->userenv[JIT_3DIP]); + emit(parent->userenv[JIT_3DIP]); i++; } else @@ -276,8 +276,8 @@ void quotation_jit::iterate_quotation() set_position(length); if(stack_frame) - emit(parent_vm->userenv[JIT_EPILOG]); - emit(parent_vm->userenv[JIT_RETURN]); + emit(parent->userenv[JIT_EPILOG]); + emit(parent->userenv[JIT_RETURN]); } } @@ -313,8 +313,8 @@ void factor_vm::primitive_array_to_quotation() { quotation *quot = allot(sizeof(quotation)); quot->array = dpeek(); - quot->cached_effect = F; - quot->cache_counter = F; + quot->cached_effect = false_object; + quot->cache_counter = false_object; quot->xt = (void *)lazy_jit_compile; quot->code = NULL; drepl(tag(quot)); @@ -367,9 +367,9 @@ cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack) return quot.value(); } -VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm) +VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *parent) { - return myvm->lazy_jit_compile_impl(quot_,stack); + return parent->lazy_jit_compile_impl(quot_,stack); } void factor_vm::primitive_quot_compiled_p() diff --git a/vm/quotations.hpp b/vm/quotations.hpp index aee4468102..feb2af1ce4 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -25,6 +25,6 @@ struct quotation_jit : public jit { void iterate_quotation(); }; -VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm); +VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *parent); } diff --git a/vm/strings.cpp b/vm/strings.cpp index ecfc84ebef..d7434fe660 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -35,7 +35,9 @@ void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch) str->data()[index] = ((ch & 0x7f) | 0x80); - if(str->aux == F) + if(to_boolean(str->aux)) + aux = untag(str->aux); + else { /* We don't need to pre-initialize the byte array with any data, since we @@ -48,8 +50,6 @@ void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch) str->aux = tag(aux); write_barrier(&str->aux); } - else - aux = untag(str->aux); aux->data()[index] = ((ch >> 7) ^ 1); } @@ -69,8 +69,8 @@ string *factor_vm::allot_string_internal(cell capacity) string *str = allot(string_size(capacity)); str->length = tag_fixnum(capacity); - str->hashcode = F; - str->aux = F; + str->hashcode = false_object; + str->aux = false_object; return str; } @@ -109,7 +109,7 @@ void factor_vm::primitive_string() bool factor_vm::reallot_string_in_place_p(string *str, cell capacity) { return nursery.contains_p(str) - && (str->aux == F || nursery.contains_p(untag(str->aux))) + && (!to_boolean(str->aux) || nursery.contains_p(untag(str->aux))) && capacity <= string_capacity(str); } @@ -121,7 +121,7 @@ string* factor_vm::reallot_string(string *str_, cell capacity) { str->length = tag_fixnum(capacity); - if(str->aux != F) + if(to_boolean(str->aux)) { byte_array *aux = untag(str->aux); aux->capacity = tag_fixnum(capacity * 2); @@ -139,7 +139,7 @@ string* factor_vm::reallot_string(string *str_, cell capacity) memcpy(new_str->data(),str->data(),to_copy); - if(str->aux != F) + if(to_boolean(str->aux)) { byte_array *new_aux = allot_byte_array(capacity * sizeof(u16)); diff --git a/vm/tagged.hpp b/vm/tagged.hpp index e7a83d0111..a61c599aeb 100755 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -29,9 +29,9 @@ struct tagged bool type_p(cell type_) const { return type() == type_; } - Type *untag_check(factor_vm *myvm) const { + Type *untag_check(factor_vm *parent) const { if(Type::type_number != TYPE_COUNT && !type_p(Type::type_number)) - myvm->type_error(Type::type_number,value_); + parent->type_error(Type::type_number,value_); return untagged(); } diff --git a/vm/tuples.cpp b/vm/tuples.cpp index 5fdde6596e..2d195ea13b 100755 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -18,7 +18,7 @@ void factor_vm::primitive_tuple() tuple *t = allot_tuple(layout.value()); fixnum i; for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) - t->data()[i] = F; + t->data()[i] = false_object; dpush(tag(t)); } diff --git a/vm/vm.hpp b/vm/vm.hpp index c3d71dc6f2..202996ce26 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -26,8 +26,8 @@ struct factor_vm /* Pooling unused contexts to make callbacks cheaper */ context *unused_contexts; - /* Canonical T object. It's just a word */ - cell T; + /* Canonical truth value. In Factor, 't' */ + cell true_object; /* Is call counting enabled? */ bool profiling_p; @@ -253,8 +253,6 @@ struct factor_vm void collect_nursery(); void collect_aging(); void collect_to_tenured(); - void big_code_heap_update(); - void small_code_heap_update(); 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); diff --git a/vm/words.cpp b/vm/words.cpp index 72460a64b9..6193a5c93c 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -14,11 +14,11 @@ word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_) new_word->vocabulary = vocab.value(); new_word->name = name.value(); new_word->def = userenv[UNDEFINED_ENV]; - new_word->props = F; + new_word->props = false_object; new_word->counter = tag_fixnum(0); - new_word->pic_def = F; - new_word->pic_tail_def = F; - new_word->subprimitive = F; + new_word->pic_def = false_object; + new_word->pic_tail_def = false_object; + new_word->subprimitive = false_object; new_word->profiling = NULL; new_word->code = NULL;