basis/stack-checker/branches/branches.factor

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