Paste: Variables optimization
Author: | littledan |
Mode: | factor |
Date: | Sat, 2 May 2009 20:22:27 |
Plain Text |
USING: kernel sequences stack-checker.transforms words assocs
math.parser classes.tuple accessors generic generic.standard
memoize hashtables slots quotations fry math slots.private
locals combinators macros arrays compiler.units vocabs ;
QUALIFIED: namespaces
QUALIFIED: namespaces.private
QUALIFIED: assocs.private
IN: new-variables
: get namespaces:get ;
<PRIVATE
SYMBOL: counter
0 counter namespaces:set-global
"new-variables.stupid" create-vocab drop
: stupid-gensym
namespaces:global
[ counter namespaces:get counter namespaces:inc ] namespaces:bind
number>string "new-variables.stupid" create ;
TUPLE: variables ;
M: variables assoc-size
drop 1 ;
GENERIC: set-variables
INSTANCE: variables assoc
: stupid-gensym-slots
length [ number>string ] map ;
: create-gensym-tuple-class
stupid-gensym [
swap stupid-gensym-slots
variables swap define-tuple-class
] [ [ swap "variables" set-word-prop ] keep ] 2bi ;
: slot-nth
"slots" word-prop nth name>> ;
: define-method
swap [ swap create-method ] dip define ;
: gensym-generic
[ gensym dup ] dip define-simple-generic ;
: define-get-word
[ [ at ] with assoc define-method ]
[ [ drop f ] variables define-method ] bi ;
MEMO: get-word
() gensym-generic
[ define-get-word ] keep ;
: replace-namespace
namespaces.private:ndrop namespaces.private:>n ;
: deoptimize-variables
>hashtable [ set-at ] keep replace-namespace ;
: define-set-word
[ [ set-at ] with assoc define-method ]
[ [ deoptimize-variables ] with variables define-method ] 2bi ;
MEMO: set-word
() gensym-generic
[ define-set-word ] keep ;
: define-get
[ slot-nth reader-word 1quotation ] keep
[ get-word ] 2dip
define-method ;
: define-set
[ slot-nth writer-word 1quotation ] keep
[ set-word ] 2dip
define-method ;
: define-get/set
'[ _ [ define-get ] [ define-set ] 3bi ] each-index ;
: variable-table
<enum> [ swap 2 + ] H{ } assoc-map-as ;
: lookup-variable
swapd at [ slot t ] [ drop f f ] if* ;
: define-at*
[ \ at* ]
[ variable-table '[ _ lookup-variable ] ]
[ define-method ] tri* ;
: variables>alist
swap tuple>array rest zip ;
: define>alist
[ \ >alist ]
[ '[ _ variables>alist ] ]
[ define-method ] tri* ;
:: set-variable
key table at
[ value swap object set-slot ]
[ value key object deoptimize-variables ] if* ;
: define-set-variables
[ \ set-variables ]
[ variable-table '[ _ set-variable ] ]
[ define-method ] tri* ;
MEMO: <scope-class>
[
dup create-gensym-tuple-class {
[ define-get/set ]
[ define-at* ]
[ define-set-variables ]
[ define>alist ]
[ nip ]
} 2cleave
] with-compilation-unit ;
: get-under
namespaces.private:namestack* [ length 2 - ] keep
assocs.private:(assoc-stack) ;
: get-wrapper
swap '[ namespaces:namespace _ execute [ _ get-under ] unless* ] ;
\ get [ dup get-word get-wrapper ] 1 define-transform
: set-wrapper
'[ namespaces:namespace _ execute ] ;
: special-associate associate ;
\ special-associate [ 1array <scope-class> '[ _ boa ] ] 1 define-transform
MACRO: special-associates
<scope-class> '[ _ boa ] ;
PRIVATE>
: set
namespaces:namespace dup variables?
[ set-variables ] [ set-at ] if ;
\ set [ set-word set-wrapper ] 1 define-transform
: with-variable
[ special-associate ] dip namespaces:bind ; inline
: with-variables
[ special-associates ] dip namespaces:bind ; inline
New Annotation