basis/stack-checker/branches/branches.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry vectors sequences assocs math math.order accessors kernel
   4 combinators quotations namespaces grouping stack-checker.state
   5 stack-checker.backend stack-checker.errors stack-checker.visitor
   6 stack-checker.values stack-checker.recursive-state ;
   7 IN: stack-checker.branches
   8
   9 : balanced? ( pairs -- ? )
  10     [ second ] filter [ first2 length - ] map all-equal? ;
  11
  12 SYMBOLS: +bottom+ +top+ ;
  13
  14 : unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
  15     ! Introduced values can be anything, and don't unify with
  16     ! literals.
  17     dup [ [ - +top+ <repetition> ] dip append ] [ 3drop f ] if ;
  18
  19 : pad-with-bottom ( seq -- newseq )
  20     ! Terminated branches are padded with bottom values which
  21     ! unify with literals.
  22     dup empty? [
  23         dup [ length ] [ max ] map-reduce
  24         '[ _ +bottom+ pad-head ] map
  25     ] unless ;
  26
  27 : phi-inputs ( max-input-count pairs -- newseq )
  28     dup empty? [ nip ] [
  29         swap '[ [ _ ] dip first2 unify-inputs ] map
  30         pad-with-bottom
  31     ] if ;
  32
  33 : remove-bottom ( seq -- seq' )
  34     +bottom+ swap remove ;
  35
  36 : unify-values ( values -- phi-out )
  37     remove-bottom
  38     [ <value> ] [
  39         [ known ] map dup all-eq?
  40         [ first make-known ] [ drop <value> ] if
  41     ] if-empty ;
  42
  43 : phi-outputs ( phi-in -- stack )
  44     flip [ unify-values ] map ;
  45
  46 SYMBOL: quotations
  47
  48 : unify-branches ( ins stacks -- in phi-in phi-out )
  49     zip [ 0 { } { } ] [
  50         [ keys supremum ] [ ] [ balanced? ] tri
  51         [ dupd phi-inputs dup phi-outputs ]
  52         [ quotations get unbalanced-branches-error ]
  53         if
  54     ] if-empty ;
  55
  56 : branch-variable ( seq symbol -- seq )
  57     '[ [ _ ] dip at ] map ;
  58
  59 : active-variable ( seq symbol -- seq )
  60     [ [ terminated? over at [ drop f ] when ] map ] dip
  61     branch-variable ;
  62
  63 : datastack-phi ( seq -- phi-in phi-out )
  64     [ input-count branch-variable ] [ \ meta-d active-variable ] bi
  65     unify-branches
  66     [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
  67
  68 : terminated-phi ( seq -- terminated )
  69     terminated? branch-variable ;
  70
  71 : terminate-branches ( seq -- )
  72     [ terminated? swap at ] all? [ terminate ] when ;
  73
  74 : compute-phi-function ( seq -- )
  75     [ quotation active-variable sift quotations set ]
  76     [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
  77     [ terminate-branches ]
  78     tri ;
  79
  80 : copy-inference ( -- )
  81     \ meta-d [ clone ] change
  82     literals [ clone ] change
  83     input-count [ ] change ;
  84
  85 GENERIC: infer-branch ( literal -- namespace )
  86
  87 M: literal infer-branch
  88     [
  89         copy-inference
  90         nest-visitor
  91         [ value>> quotation set ] [ infer-literal-quot ] bi
  92     ] H{ } make-assoc ;
  93
  94 M: callable infer-branch
  95     [
  96         copy-inference
  97         nest-visitor
  98         [ quotation set ] [ infer-quot-here ] bi
  99     ] H{ } make-assoc ;
 100
 101 : infer-branches ( branches -- input children data )
 102     [ pop-d ] dip
 103     [ infer-branch ] map
 104     [ stack-visitor branch-variable ] keep ; inline
 105
 106 : (infer-if) ( branches -- )
 107     infer-branches
 108     [ first2 #if, ] dip compute-phi-function ;
 109
 110 : infer-if ( -- )
 111     2 literals-available? [
 112         (infer-if)
 113     ] [
 114         drop 2 consume-d
 115         dup [ known [ curried? ] [ composed? ] bi or ] any? [
 116             output-d
 117             [ rot [ drop call ] [ nip call ] if ]
 118             infer-quot-here
 119         ] [
 120             [ #drop, ] [ [ literal ] map (infer-if) ] bi
 121         ] if
 122     ] if ;
 123
 124 : infer-dispatch ( -- )
 125     pop-literal nip infer-branches
 126     [ #dispatch, ] dip compute-phi-function ;