Various optimizations leading to a 10% speedup on compiling empty EBNF parser:
- open-code getenv primitive
- inline tuple predicates in finalization
- faster partial dispatch
- faster built-in type predicates
- faster tuple predicates
- faster lo-tag dispatch
- compile V{ } clone and H{ } clone more efficiently
- add fixnum fast-path to =; avoid indirect branch if two fixnums not eq
- faster >alist on hashtables
db4
Slava Pestov
parent
e95bda8144
commit
a56d480aa6
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes compiler.cfg
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.copy-prop ;
|
||||
|
|
@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
|
|||
M: ##slot-imm insn-slot# slot>> ;
|
||||
M: ##set-slot insn-slot# slot>> constant ;
|
||||
M: ##set-slot-imm insn-slot# slot>> ;
|
||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||
|
||||
M: ##peek insn-object loc>> class ;
|
||||
M: ##replace insn-object loc>> class ;
|
||||
|
|
@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ;
|
|||
M: ##slot-imm insn-object obj>> resolve ;
|
||||
M: ##set-slot insn-object obj>> resolve ;
|
||||
M: ##set-slot-imm insn-object obj>> resolve ;
|
||||
M: ##alien-global insn-object drop \ ##alien-global ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
H{ } clone histories set
|
||||
|
|
@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
|
|||
M: ##load-indirect analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##allot analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
|
|
|
|||
|
|
@ -65,6 +65,7 @@ IN: compiler.cfg.hats
|
|||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
|
||||
|
|
|
|||
|
|
@ -161,6 +161,8 @@ INSN: ##set-alien-double < ##alien-setter ;
|
|||
INSN: ##allot < ##flushable size class { temp vreg } ;
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
|
||||
INSN: ##alien-global < ##read symbol library ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke params ;
|
||||
INSN: ##alien-indirect params ;
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@ compiler.cfg.registers ;
|
|||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
D 0 ^^peek
|
||||
D 1 ^^peek
|
||||
2inputs
|
||||
^^or
|
||||
tag-mask get ^^and-imm
|
||||
0 cc= ^^compare-imm
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.iterator ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
|
|
@ -23,6 +24,7 @@ IN: compiler.cfg.intrinsics
|
|||
|
||||
{
|
||||
kernel.private:tag
|
||||
kernel.private:getenv
|
||||
math.private:both-fixnums?
|
||||
math.private:fixnum+
|
||||
math.private:fixnum-
|
||||
|
|
@ -94,6 +96,7 @@ IN: compiler.cfg.intrinsics
|
|||
: emit-intrinsic ( node word -- node/f )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv iterate-next ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces layouts sequences kernel
|
||||
accessors compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.misc
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-getenv ( node -- )
|
||||
"userenv" f ^^alien-global
|
||||
swap node-input-infos first literal>>
|
||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||
ds-push ;
|
||||
|
|
@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
|||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
|
|
|
|||
|
|
@ -236,6 +236,10 @@ M: _gc generate-insn drop %gc ;
|
|||
|
||||
M: ##loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
M: ##alien-global generate-insn
|
||||
[ dst>> register ] [ symbol>> ] [ library>> ] tri
|
||||
%alien-global ;
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize classes.builtin
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
|
|
@ -12,7 +13,7 @@ IN: compiler.tree.finalization
|
|||
! See the comment in compiler.tree.late-optimizations.
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates; these cannot be expanded before
|
||||
! type predicates; these cannot be expanded before
|
||||
! propagation since we need to see 'fixnum?' instead of
|
||||
! 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
|
||||
|
|
@ -33,16 +34,24 @@ M: #shuffle finalize*
|
|||
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
|
||||
bi and [ drop f ] when ;
|
||||
|
||||
: builtin-predicate? ( #call -- ? )
|
||||
word>> "predicating" word-prop builtin-class? ;
|
||||
|
||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||
MEMO: cached-expansion ( word -- nodes )
|
||||
def>> splice-final ;
|
||||
|
||||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
GENERIC: finalize-word ( #call word -- nodes )
|
||||
|
||||
M: predicate finalize-word
|
||||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
! M: math-partial finalize-word
|
||||
! dup primitive? [ drop ] [ nip cached-expansion ] if ;
|
||||
|
||||
M: word finalize-word drop ;
|
||||
|
||||
M: #call finalize*
|
||||
dup builtin-predicate? [ expand-builtin-predicate ] when ;
|
||||
dup word>> finalize-word ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
|
|
|||
|
|
@ -193,13 +193,14 @@ SYMBOL: history
|
|||
#! of bounds value. This case comes up if a parsing word
|
||||
#! calls the compiler at parse time (doing so is
|
||||
#! discouraged, but it should still work.)
|
||||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup custom-inlining? ] [ inline-custom ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [
|
||||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
[ 2drop f ]
|
||||
} cond
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order
|
|||
layouts words sequences sequences.private arrays assocs classes
|
||||
classes.algebra combinators generic.math splitting fry locals
|
||||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions strings.private
|
||||
definitions strings.private vectors hashtables
|
||||
stack-checker.state
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -194,6 +194,11 @@ generic-comparison-ops [
|
|||
2bi and maybe-or-never
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ both-fixnums? [
|
||||
[ class>> fixnum classes-intersect? not ] either?
|
||||
f <literal-info> object-info ?
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ bignum>fixnum fixnum }
|
||||
|
|
@ -287,6 +292,15 @@ generic-comparison-ops [
|
|||
"outputs" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop hashtable new ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
|
|
|||
|
|
@ -120,6 +120,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- )
|
|||
HOOK: %set-alien-float cpu ( ptr value -- )
|
||||
HOOK: %set-alien-double cpu ( ptr value -- )
|
||||
|
||||
HOOK: %alien-global cpu ( dst symbol library -- )
|
||||
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
|
|
|||
|
|
@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ;
|
|||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
|
|
|
|||
|
|
@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- )
|
|||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-global
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
|
|
|
|||
|
|
@ -381,8 +381,8 @@ big-endian off
|
|||
|
||||
[
|
||||
arg0 ds-reg [] MOV
|
||||
arg0 ds-reg bootstrap-cell neg [+] OR
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg bootstrap-cell SUB
|
||||
arg0 ds-reg [] OR
|
||||
arg0 tag-mask get AND
|
||||
arg0 \ f tag-number MOV
|
||||
arg1 1 tag-fixnum MOV
|
||||
|
|
|
|||
|
|
@ -458,19 +458,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
|
|||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||
|
||||
M:: x86 %write-barrier ( src card# table -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
card# src MOV
|
||||
card# card-bits SHR
|
||||
"cards_offset" f table %alien-global
|
||||
table "cards_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
card# deck-bits card-bits - SHR
|
||||
"decks_offset" f table %alien-global
|
||||
table "decks_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
|
|
@ -485,6 +485,9 @@ M: x86 %gc ( -- )
|
|||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
M: x86 %alien-global
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
|
|
@ -595,7 +598,8 @@ M: x86 %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f temp-reg-1 %alien-global
|
||||
temp-reg-1 "stack_chain" f %alien-global
|
||||
temp-reg-1 temp-reg-1 [] MOV
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel kernel.private math math.private words
|
||||
sequences parser namespaces make assocs quotations arrays locals
|
||||
generic generic.math hashtables effects compiler.units
|
||||
classes.algebra ;
|
||||
classes.algebra fry combinators ;
|
||||
IN: math.partial-dispatch
|
||||
|
||||
PREDICATE: math-partial < word
|
||||
|
|
@ -45,60 +45,62 @@ M: word integer-op-input-classes
|
|||
{ bitnot fixnum-bitnot }
|
||||
} at swap or ;
|
||||
|
||||
:: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a fixnum>bignum b big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
a tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a b fixnum>bignum big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word big-word integer-fixnum-op
|
||||
] [
|
||||
a dup tag 0 eq? [ fixnum>bignum ] when
|
||||
b big-word execute
|
||||
] if ; inline
|
||||
|
||||
: integer-op-combinator ( triple -- word )
|
||||
:: integer-fixnum-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ second name>> % "-" % ]
|
||||
[ third name>> % "-op" % ]
|
||||
bi
|
||||
] "" make "math.partial-dispatch" lookup ;
|
||||
[ over fixnum? ] %
|
||||
fix-word '[ _ execute ] ,
|
||||
big-word '[ fixnum>bignum _ execute ] ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
:: fixnum-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
fix-word '[ _ execute ] ,
|
||||
big-word '[ [ fixnum>bignum ] dip _ execute ] ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
:: integer-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
fix-word big-word integer-fixnum-op-quot ,
|
||||
[
|
||||
[ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
|
||||
big-word ,
|
||||
] [ ] make ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: integer-op-word ( triple -- word )
|
||||
[ name>> ] map "-" join "math.partial-dispatch" create ;
|
||||
|
||||
: integer-op-quot ( triple fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
: integer-op-quot ( fix-word big-word triple -- quot )
|
||||
[ second ] [ third ] bi 2array {
|
||||
{ { fixnum integer } [ fixnum-integer-op-quot ] }
|
||||
{ { integer fixnum } [ integer-fixnum-op-quot ] }
|
||||
{ { integer integer } [ integer-integer-op-quot ] }
|
||||
} case ;
|
||||
|
||||
: define-integer-op-word ( triple fix-word big-word -- )
|
||||
: define-integer-op-word ( fix-word big-word triple -- )
|
||||
[
|
||||
[ 2drop integer-op-word ] [ integer-op-quot ] 3bi
|
||||
[ 2nip integer-op-word ] [ integer-op-quot ] 3bi
|
||||
(( x y -- z )) define-declared
|
||||
] [
|
||||
2drop
|
||||
2nip
|
||||
[ integer-op-word ] keep
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( triples fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
'[ [ _ _ ] dip define-integer-op-word ] each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
} swap '[ _ prefix ] map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
[
|
||||
|
|
@ -138,7 +140,7 @@ SYMBOL: fast-math-ops
|
|||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-filter ;
|
||||
swap '[ swap first _ eq? nip ] assoc-filter ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ] [ math-ops get (derived-ops) values ] bi append ;
|
||||
|
|
|
|||
|
|
@ -307,7 +307,7 @@ M: object infer-call*
|
|||
\ <complex> { real real } { complex } define-primitive
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ both-fixnums? { object object } { object object object } define-primitive
|
||||
\ both-fixnums? { object object } { object } define-primitive
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||
\ fixnum+ make-foldable
|
||||
|
|
|
|||
|
|
@ -109,9 +109,6 @@ bootstrapping? on
|
|||
} [ create-vocab drop ] each
|
||||
|
||||
! Builtin classes
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup class>type [ builtin-instance? ] curry define-predicate ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
|
|
@ -192,6 +189,10 @@ define-union-class
|
|||
] [ ] make
|
||||
define-predicate-class
|
||||
|
||||
"array-capacity" "sequences.private" lookup
|
||||
[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append
|
||||
"coercer" set-word-prop
|
||||
|
||||
! Catch-all class for providing a default method.
|
||||
"object" "kernel" create
|
||||
[ f f { } intersection-class define-class ]
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes classes.algebra words kernel
|
||||
kernel.private namespaces sequences math math.private
|
||||
combinators assocs ;
|
||||
combinators assocs quotations ;
|
||||
IN: classes.builtin
|
||||
|
||||
SYMBOL: builtins
|
||||
|
|
@ -10,10 +10,14 @@ SYMBOL: builtins
|
|||
PREDICATE: builtin-class < class
|
||||
"metaclass" word-prop builtin-class eq? ;
|
||||
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: class>type ( class -- n ) "type" word-prop ; foldable
|
||||
|
||||
PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
|
||||
|
||||
PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
|
||||
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
M: hi-tag class hi-tag type>class ;
|
||||
|
|
@ -22,16 +26,20 @@ M: object class tag type>class ;
|
|||
|
||||
M: builtin-class rank-class drop 0 ;
|
||||
|
||||
: builtin-instance? ( object n -- ? )
|
||||
#! 7 == tag-mask get
|
||||
#! 3 == hi-tag tag-number
|
||||
dup 7 fixnum<= [ swap tag eq? ] [
|
||||
swap dup tag 3 eq?
|
||||
[ hi-tag eq? ] [ 2drop f ] if
|
||||
] if ; inline
|
||||
GENERIC: define-builtin-predicate ( class -- )
|
||||
|
||||
M: builtin-class instance?
|
||||
class>type builtin-instance? ;
|
||||
M: lo-tag-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
|
||||
|
||||
M: hi-tag-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
|
||||
[ dup tag 3 eq? ] [ [ drop f ] if ] surround
|
||||
define-predicate ;
|
||||
|
||||
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
|
||||
|
||||
M: hi-tag-class instance?
|
||||
over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
|
||||
|
||||
M: builtin-class (flatten-class) dup set ;
|
||||
|
||||
|
|
|
|||
|
|
@ -90,10 +90,10 @@ ERROR: bad-superclass class ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: tuple-instance-1? ( object class -- ? )
|
||||
swap dup tuple? [
|
||||
layout-of 7 slot eq?
|
||||
] [ 2drop f ] if ; inline
|
||||
: tuple-predicate-quot/1 ( class -- quot )
|
||||
#! Fast path for tuples with no superclass
|
||||
[ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
|
||||
[ dup tuple? ] [ [ drop f ] if ] surround ;
|
||||
|
||||
: tuple-instance? ( object class offset -- ? )
|
||||
rot dup tuple? [
|
||||
|
|
@ -105,13 +105,16 @@ ERROR: bad-superclass class ;
|
|||
: layout-class-offset ( echelon -- n )
|
||||
2 * 5 + ;
|
||||
|
||||
: tuple-predicate-quot ( class echelon -- quot )
|
||||
layout-class-offset [ tuple-instance? ] 2curry ;
|
||||
|
||||
: echelon-of ( class -- n )
|
||||
tuple-layout third ;
|
||||
|
||||
: define-tuple-predicate ( class -- )
|
||||
dup dup echelon-of {
|
||||
{ 1 [ [ tuple-instance-1? ] curry ] }
|
||||
[ layout-class-offset [ tuple-instance? ] 2curry ]
|
||||
{ 1 [ tuple-predicate-quot/1 ] }
|
||||
[ tuple-predicate-quot ]
|
||||
} case define-predicate ;
|
||||
|
||||
: class-size ( class -- n )
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: math-combination perform-combination
|
|||
drop
|
||||
dup
|
||||
[
|
||||
\ both-fixnums? ,
|
||||
[ 2dup both-fixnums? ] %
|
||||
dup fixnum bootstrap-word dup math-method ,
|
||||
\ over [
|
||||
dup math-class? [
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: classes.private generic.standard.engines namespaces make
|
||||
arrays assocs sequences.private quotations kernel.private
|
||||
math slots.private math.private kernel accessors words
|
||||
layouts sorting sequences ;
|
||||
layouts sorting sequences combinators ;
|
||||
IN: generic.standard.engines.tag
|
||||
|
||||
TUPLE: lo-tag-dispatch-engine methods ;
|
||||
|
|
@ -24,15 +24,21 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
|
|||
|
||||
: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
|
||||
|
||||
: tag-dispatch-test ( tag# -- quot )
|
||||
picker [ tag ] append swap [ eq? ] curry append ;
|
||||
|
||||
: tag-dispatch-quot ( alist -- quot )
|
||||
[ default get ] dip
|
||||
[ [ tag-dispatch-test ] dip ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
M: lo-tag-dispatch-engine engine>quot
|
||||
methods>> engines>quots*
|
||||
[ [ lo-tag-number ] dip ] assoc-map
|
||||
[
|
||||
picker % [ tag ] % [
|
||||
sort-tags linear-dispatch-quot
|
||||
] [
|
||||
num-tags get direct-dispatch-quot
|
||||
] if-small? %
|
||||
[ sort-tags tag-dispatch-quot ]
|
||||
[ picker % [ tag ] % num-tags get direct-dispatch-quot ]
|
||||
if-small? %
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: hi-tag-dispatch-engine methods ;
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
|
|||
: push-unsafe ( elt seq -- )
|
||||
[ length ] keep
|
||||
[ underlying>> set-array-nth ]
|
||||
[ [ 1+ ] dip (>>length) ]
|
||||
[ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
|
||||
2bi ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -154,8 +154,11 @@ TUPLE: identity-tuple ;
|
|||
|
||||
M: identity-tuple equal? 2drop f ;
|
||||
|
||||
USE: math.private
|
||||
: = ( obj1 obj2 -- ? )
|
||||
2dup eq? [ 2drop t ] [ equal? ] if ; inline
|
||||
2dup eq? [ 2drop t ] [
|
||||
2dup both-fixnums? [ 2drop f ] [ equal? ] if
|
||||
] if ; inline
|
||||
|
||||
GENERIC: clone ( obj -- cloned )
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue