/core/generic/standard/standard.factor

http://github.com/abeaumont/factor · Factor · 63 lines · 44 code · 17 blank · 2 comment · 3 complexity · 78db01ffbbe88ab7ec31ca9de040e7df MD5 · raw file

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