unfinished/compiler/cfg/templates/templates.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs accessors sequences kernel fry namespaces
   4 quotations combinators classes.algebra compiler.instructions
   5 compiler.registers compiler.cfg.stacks ;
   6 IN: compiler.cfg.templates
   7
   8 USE: qualified
   9 FROM: compiler.generator.registers => +input+   ;
  10 FROM: compiler.generator.registers => +output+  ;
  11 FROM: compiler.generator.registers => +scratch+ ;
  12 FROM: compiler.generator.registers => +clobber+ ;
  13
  14 : template-input +input+ swap at ; inline
  15 : template-output +output+ swap at ; inline
  16 : template-scratch +scratch+ swap at ; inline
  17 : template-clobber +clobber+ swap at ; inline
  18
  19 : phantom&spec ( phantom specs -- phantom' specs' )
  20     >r stack>> r>
  21     [ length f pad-left ] keep
  22     [ <reversed> ] bi@ ; inline
  23
  24 : phantom&spec-agree? ( phantom spec quot -- ? )
  25     >r phantom&spec r> 2all? ; inline
  26
  27 : live-vregs ( -- seq )
  28     [ stack>> [ >vreg ] map sift ] each-phantom append ;
  29
  30 : clobbered ( template -- seq )
  31     [ template-output ] [ template-clobber ] bi append ;
  32
  33 : clobbered? ( value name -- ? )
  34     \ clobbered get member? [
  35         >vreg \ live-vregs get member?
  36     ] [ drop f ] if ;
  37
  38 : lazy-load ( specs -- seq )
  39     [ length phantom-datastack get phantom-input ] keep
  40     [ drop ] [
  41         [
  42             2dup second clobbered?
  43             [ first (eager-load) ] [ first (lazy-load) ] if
  44         ] 2map
  45     ] 2bi
  46     [ substitute-vregs ] keep ;
  47
  48 : load-inputs ( template -- assoc )
  49     [
  50         live-vregs \ live-vregs set
  51         dup clobbered \ clobbered set
  52         template-input [ values ] [ lazy-load ] bi zip
  53     ] with-scope ;
  54
  55 : alloc-scratch ( template -- assoc )
  56     template-scratch [ swap alloc-vreg ] assoc-map ;
  57
  58 : do-template-inputs ( template -- inputs )
  59     #! Load input values into registers and allocates scratch
  60     #! registers.
  61     [ load-inputs ] [ alloc-scratch ] bi assoc-union ;
  62
  63 : do-template-outputs ( template inputs -- )
  64     [ template-output ] dip '[ _ at ] map
  65     phantom-datastack get phantom-append ;
  66
  67 : apply-template ( pair quot -- vregs )
  68     [
  69         first2 dup do-template-inputs
  70         [ do-template-outputs ] keep
  71     ] dip call ; inline
  72
  73 : value-matches? ( value spec -- ? )
  74     #! If the spec is a quotation and the value is a literal
  75     #! fixnum, see if the quotation yields true when applied
  76     #! to the fixnum. Otherwise, the values don't match. If the
  77     #! spec is not a quotation, its a reg-class, in which case
  78     #! the value is always good.
  79     dup quotation? [
  80         over constant?
  81         [ >r value>> r> 2drop f ] [ 2drop f ] if
  82     ] [
  83         2drop t
  84     ] if ;
  85
  86 : class-matches? ( actual expected -- ? )
  87     {
  88         { f [ drop t ] }
  89         { known-tag [ dup [ class-tag >boolean ] when ] }
  90         [ class<= ]
  91     } case ;
  92
  93 : spec-matches? ( value spec -- ? )
  94     2dup first value-matches?
  95     >r >r operand-class 2 r> ?nth class-matches? r> and ;
  96
  97 : template-matches? ( template -- ? )
  98     template-input phantom-datastack get swap
  99     [ spec-matches? ] phantom&spec-agree? ;
 100
 101 : find-template ( templates -- pair/f )
 102     #! Pair has shape { quot assoc }
 103     [ second template-matches? ] find nip ;