core/optimizer/specializers/specializers.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: arrays generic hashtables kernel kernel.private math\r
   4 namespaces sequences vectors words strings layouts combinators\r
   5 sequences.private classes generic.standard\r
   6 generic.standard.engines assocs ;\r
   7 IN: optimizer.specializers\r
   8 \r
   9 : (make-specializer) ( class picker -- quot )\r
  10     swap "predicate" word-prop append ;\r
  11 \r
  12 : make-specializer ( classes -- quot )\r
  13     dup length <reversed>\r
  14     [ (picker) 2array ] 2map\r
  15     [ drop object eq? not ] assoc-filter\r
  16     dup empty? [ drop [ t ] ] [\r
  17         [ (make-specializer) ] { } assoc>map\r
  18         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce\r
  19     ] if ;\r
  20 \r
  21 : tag-specializer ( quot -- newquot )\r
  22     [\r
  23         [ dup tag ] %\r
  24         num-tags get swap <array> ,\r
  25         \ dispatch ,\r
  26     ] [ ] make ;\r
  27 \r
  28 : specializer-cases ( quot word -- default alist )\r
  29     dup [ array? ] all? [ 1array ] unless [\r
  30         [ make-specializer ] keep\r
  31         [ declare ] curry pick append\r
  32     ] { } map>assoc ;\r
  33 \r
  34 : method-declaration ( method -- quot )\r
  35     dup "method-generic" word-prop dispatch# object <array>\r
  36     swap "method-class" word-prop prefix ;\r
  37 \r
  38 : specialize-method ( quot method -- quot' )\r
  39     method-declaration [ declare ] curry prepend ;\r
  40 \r
  41 : specialize-quot ( quot specializer -- quot' )\r
  42     dup { number } = [\r
  43         drop tag-specializer\r
  44     ] [\r
  45         specializer-cases alist>quot\r
  46     ] if ;\r
  47 \r
  48 : standard-method? ( method -- ? )\r
  49     dup method-body? [\r
  50         "method-generic" word-prop standard-generic?\r
  51     ] [ drop f ] if ;\r
  52 \r
  53 : specialized-def ( word -- quot )\r
  54     dup word-def swap {\r
  55         { [ dup standard-method? ] [ specialize-method ] }\r
  56         {\r
  57             [ dup "specializer" word-prop ]\r
  58             [ "specializer" word-prop specialize-quot ]\r
  59         }\r
  60         [ drop ]\r
  61     } cond ;\r
  62 \r
  63 : specialized-length ( specializer -- n )\r
  64     dup [ array? ] all? [ first ] when length ;\r