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 ;
   7 IN: generic.standard
   8
   9 TUPLE: standard-combination < single-combination # ;
  10
  11 : <standard-combination> ( n -- standard-combination )
  12     dup 0 2 between? [ "Bad dispatch position" throw ] unless
  13     standard-combination boa ;
  14
  15 PREDICATE: standard-generic < generic
  16     "combination" word-prop standard-combination? ;
  17
  18 PREDICATE: simple-generic < standard-generic
  19     "combination" word-prop #>> 0 = ;
  20
  21 CONSTANT: simple-combination T{ standard-combination f 0 }
  22
  23 : define-simple-generic ( word effect -- )
  24     [ simple-combination ] dip define-generic ;
  25
  26 : (picker) ( n -- quot )
  27     {
  28         { 0 [ [ dup ] ] }
  29         { 1 [ [ over ] ] }
  30         { 2 [ [ pick ] ] }
  31         [ 1 - (picker) [ dip swap ] curry ]
  32     } case ;
  33
  34 M: standard-combination picker
  35     combination get #>> (picker) ;
  36
  37 M: standard-combination dispatch# #>> ;
  38
  39 M: standard-generic effective-method
  40     [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
  41     (effective-method) ;
  42
  43 M: standard-combination inline-cache-quot ( word methods -- )
  44     #! Direct calls to the generic word (not tail calls or indirect calls)
  45     #! will jump to the inline cache entry point instead of the megamorphic
  46     #! dispatch entry point.
  47     combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
  48
  49 : make-empty-cache ( -- array )
  50     mega-cache-size get f <array> ;
  51
  52 M: standard-combination mega-cache-quot
  53     combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
  54
  55 M: standard-generic definer drop \ GENERIC# f ;
  56
  57 M: simple-generic definer drop \ GENERIC: f ;