core/generic/standard/standard.factor

   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 ;
   6 IN: generic.standard
   7
   8 ERROR: bad-dispatch-position # ;
   9
  10 TUPLE: standard-combination < single-combination # ;
  11
  12 : <standard-combination> ( # -- standard-combination )
  13     dup integer? [ dup 0 < ] [ t ] if
  14     [ bad-dispatch-position ] when
  15     standard-combination boa ;
  16
  17 M: standard-combination check-combination-effect
  18     [ dispatch# ] [ in>> length ] bi* over >
  19     [ drop ] [ bad-dispatch-position ] if ;
  20
  21 PREDICATE: standard-generic < generic
  22     "combination" word-prop standard-combination? ;
  23
  24 PREDICATE: simple-generic < standard-generic
  25     "combination" word-prop #>> 0 = ;
  26
  27 CONSTANT: simple-combination T{ standard-combination f 0 }
  28
  29 : define-simple-generic ( word effect -- )
  30     [ simple-combination ] dip define-generic ;
  31
  32 : (picker) ( n -- quot )
  33     {
  34         { 0 [ [ dup ] ] }
  35         { 1 [ [ over ] ] }
  36         { 2 [ [ pick ] ] }
  37         [ 1 - (picker) [ dip swap ] curry ]
  38     } case ;
  39
  40 M: standard-combination picker
  41     combination get #>> (picker) ;
  42
  43 M: standard-combination dispatch# #>> ;
  44
  45 M: standard-generic effective-method
  46     [ get-datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
  47     method-for-object ;
  48
  49 : inline-cache-quot ( word methods miss-word -- quot )
  50     [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
  51
  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 ]
  58     2bi ;
  59
  60 : make-empty-cache ( -- array )
  61     mega-cache-size get f <array> ;
  62
  63 M: standard-combination mega-cache-quot
  64     combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
  65
  66 M: standard-generic definer drop \ GENERIC# f ;
  67
  68 M: simple-generic definer drop \ GENERIC: f ;