Paste: Variables optimization

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 ( variable -- value ) namespaces:get ;

<PRIVATE

SYMBOL: counter
0 counter namespaces:set-global

"new-variables.stupid" create-vocab drop

: stupid-gensym ( -- word )
    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 ( value key variables -- )

INSTANCE: variables assoc

: stupid-gensym-slots ( slots -- slot-names )
    length [ number>string ] map ;

: create-gensym-tuple-class ( slots -- tuple-class )
    stupid-gensym [
        swap stupid-gensym-slots
        variables swap define-tuple-class
    ] [ [ swap "variables" set-word-prop ] keep ] 2bi ;

: slot-nth ( index class -- name )
    "slots" word-prop nth name>> ;

: define-method ( generic definition class -- )
    swap [ swap create-method ] dip define ;

: gensym-generic ( effect -- word )
    [ gensym dup ] dip define-simple-generic ;

: define-get-word ( variable generic -- )
    [ [ at ] with assoc define-method ]
    [ [ drop f ] variables define-method ] bi ;

MEMO: get-word ( variable -- word )
    (( assoc -- value )) gensym-generic
    [ define-get-word ] keep ;

: replace-namespace ( namespace -- )
    namespaces.private:ndrop namespaces.private:>n ;

: deoptimize-variables ( value key variables -- )
    >hashtable [ set-at ] keep replace-namespace ;

: define-set-word ( variable generic -- )
    [ [ set-at ] with assoc define-method ]
    [ [ deoptimize-variables ] with variables define-method ] 2bi ;

MEMO: set-word ( variable -- word )
    (( value assoc -- )) gensym-generic
    [ define-set-word ] keep ;

: define-get ( slot index class -- )
    [ slot-nth reader-word 1quotation ] keep
    [ get-word ] 2dip
    define-method ;

: define-set ( slot index class -- )
    [ slot-nth writer-word 1quotation ] keep
    [ set-word ] 2dip
    define-method ;

: define-get/set ( variables class -- )
    '[ _ [ define-get ] [ define-set ] 3bi ] each-index ;

: variable-table ( variables -- hash )
    <enum> [ swap 2 + ] H{ } assoc-map-as ;

: lookup-variable ( key object table -- value/f ? )
    swapd at [ slot t ] [ drop f f ] if* ;

: define-at* ( variables class -- )
    [ \ at* ]
    [ variable-table '[ _ lookup-variable ] ]
    [ define-method ] tri* ;

: variables>alist ( object slots -- alist )
    swap tuple>array rest zip ;

: define>alist ( variables class -- )
    [ \ >alist ]
    [ '[ _ variables>alist ] ]
    [ define-method ] tri* ;

:: set-variable ( value key object table -- )
    key table at
    [ value swap object set-slot ]
    [ value key object deoptimize-variables ] if* ;

: define-set-variables ( variables class -- )
    [ \ set-variables ]
    [ variable-table '[ _ set-variable ] ]
    [ define-method ] tri* ;

MEMO: <scope-class> ( variables -- class )
    [
        dup create-gensym-tuple-class {
            [ define-get/set ]
            [ define-at* ]
            [ define-set-variables ]
            [ define>alist ]
            [ nip ]
        } 2cleave
    ] with-compilation-unit ;

: get-under ( variable -- value )
    namespaces.private:namestack* [ length 2 - ] keep
    assocs.private:(assoc-stack) ;

: get-wrapper ( variable word -- quot )
     swap '[ namespaces:namespace _ execute [ _ get-under ] unless* ] ;

\ get [ dup get-word get-wrapper ] 1 define-transform

: set-wrapper ( word -- quot )
    '[ namespaces:namespace _ execute ] ;

: special-associate ( value key -- hashtable ) associate ;

\ special-associate [ 1array <scope-class> '[ _ boa ] ] 1 define-transform

MACRO: special-associates ( variables -- quot )
    <scope-class> '[ _ boa ] ;

PRIVATE>

: set ( value variable -- )
    namespaces:namespace dup variables?
    [ set-variables ] [ set-at ] if ;

\ set [ set-word set-wrapper ] 1 define-transform

: with-variable ( value key quot -- )
    [ special-associate ] dip namespaces:bind ; inline

: with-variables ( ... keys quot -- )
    [ special-associates ] dip namespaces:bind ; inline