core/generic/standard/standard.factor

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