unmaintained/specialized/specialized.factor

   1 ! Copyright (C) 2009, 2010 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words kernel locals accessors compiler.tree.propagation.info
   4 sequences kernel.private assocs fry parser math quotations
   5 effects arrays definitions compiler.units namespaces
   6 compiler.tree.debugger generalizations stack-checker ;
   7 IN: specialized
   8
   9 : in-compilation-unit? ( -- ? )
  10     changed-definitions get >boolean ;
  11
  12 : define-temp-in-unit ( quot effect -- word )
  13     in-compilation-unit?
  14     [ [ define-temp ] with-nested-compilation-unit ]
  15     [ [ define-temp ] with-compilation-unit ]
  16     if ;
  17
  18 : final-info-quot ( word -- quot )
  19     [ stack-effect in>> length '[ _ ndrop ] ]
  20     [ def>> [ final-info ] with-scope >quotation ] bi
  21     compose ;
  22
  23 ERROR: bad-outputs word quot ;
  24
  25 : define-outputs ( word quot -- )
  26     2dup [ stack-effect ] [ infer ] bi* effect<=
  27     [ "outputs" set-word-prop ] [ bad-outputs ] if ;
  28
  29 : record-final-info ( word -- )
  30     dup final-info-quot define-outputs ;
  31
  32 :: lookup-specialized ( #call word n -- special-word/f )
  33     #call in-d>> n tail* >array [ value-info class>> ] map
  34     dup [ object = ] all? [ drop f ] [
  35         word "specialized-defs" word-prop [
  36             [ declare ] curry word def>> compose
  37             word stack-effect define-temp-in-unit
  38             dup record-final-info
  39             1quotation
  40         ] cache
  41     ] if ;
  42
  43 : specialized-quot ( word n -- quot )
  44     '[ _ _ lookup-specialized ] ;
  45
  46 : make-specialized ( word n -- )
  47     [ drop H{ } clone "specialized-defs" set-word-prop ]
  48     [ dupd specialized-quot "custom-inlining" set-word-prop ] 2bi ;
  49
  50 SYNTAX: specialized
  51     last-word dup stack-effect in>> length make-specialized ;
  52
  53 PREDICATE: specialized-word < word
  54    "specialized-defs" word-prop >boolean ;