1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators definitions generic
4 generic.single generic.single.private kernel layouts make math
5 namespaces quotations sequences words ;
8 ERROR: bad-dispatch-position # ;
10 TUPLE: standard-combination < single-combination # ;
12 : <standard-combination> ( # -- standard-combination )
13 dup integer? [ dup 0 < ] [ t ] if
14 [ bad-dispatch-position ] when
15 standard-combination boa ;
17 M: standard-combination check-combination-effect
18 [ dispatch# ] [ in>> length ] bi* over >
19 [ drop ] [ bad-dispatch-position ] if ;
21 PREDICATE: standard-generic < generic
22 "combination" word-prop standard-combination? ;
24 PREDICATE: simple-generic < standard-generic
25 "combination" word-prop #>> 0 = ;
27 CONSTANT: simple-combination T{ standard-combination f 0 }
29 : define-simple-generic ( word effect -- )
30 [ simple-combination ] dip define-generic ;
32 : (picker) ( n -- quot )
37 [ 1 - (picker) [ dip swap ] curry ]
40 M: standard-combination picker
41 combination get #>> (picker) ;
43 M: standard-combination dispatch# #>> ;
45 M: standard-generic effective-method
46 [ get-datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
49 : inline-cache-quot ( word methods miss-word -- quot )
50 [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
52 M: standard-combination inline-cache-quots
53 ! Direct calls to the generic word (not tail calls or indirect calls)
54 ! will jump to the inline cache entry point instead of the megamorphic
55 ! dispatch entry point.
56 [ \ inline-cache-miss inline-cache-quot ]
57 [ \ inline-cache-miss-tail inline-cache-quot ]
60 : make-empty-cache ( -- array )
61 mega-cache-size get f <array> ;
63 M: standard-combination mega-cache-quot
64 combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
66 M: standard-generic definer drop \ GENERIC# f ;
68 M: simple-generic definer drop \ GENERIC: f ;