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     [ [ - +top+ <repetition> ] dip append ] [ 2drop 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 longest length
  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     '[ _ of ] 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? of ] 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 : collect-variables ( -- hash )
  96     {
  97         (meta-d)
  98         (meta-r)
  99         current-word
 100         inner-d-index
 101         input-count
 102         literals
 103         quotation
 104         recursive-state
 105         stack-visitor
 106         terminated?
 107     } [ dup get ] H{ } map>assoc ;
 108
 109 GENERIC: infer-branch ( literal -- namespace )
 110
 111 M: literal-tuple infer-branch
 112     [
 113         copy-inference
 114         nest-visitor
 115         [ value>> quotation set ] [ infer-literal-quot ] bi
 116         collect-variables
 117     ] with-scope ;
 118
 119 M: declared-effect infer-branch
 120     known>> infer-branch ;
 121
 122 M: callable infer-branch
 123     [
 124         copy-inference
 125         nest-visitor
 126         [ quotation set ] [ infer-quot-here ] bi
 127         collect-variables
 128     ] with-scope ;
 129
 130 : infer-branches ( branches -- input children data )
 131     [ pop-d ] dip
 132     [ infer-branch ] map
 133     [ stack-visitor branch-variable ] keep ; inline
 134
 135 : (infer-if) ( branches -- )
 136     infer-branches
 137     [ first2 #if, ] dip compute-phi-function ;
 138
 139 GENERIC: curried/composed? ( known -- ? )
 140 M: object curried/composed? drop f ;
 141 M: curried curried/composed? drop t ;
 142 M: composed curried/composed? drop t ;
 143 M: declared-effect curried/composed? known>> curried/composed? ;
 144
 145 : declare-if-effects ( -- )
 146     H{ } clone V{ } clone
 147     [ [ \ if ( ..a -- ..b ) ] 2dip 0 declare-effect-d ]
 148     [ [ \ if ( ..a -- ..b ) ] 2dip 1 declare-effect-d ] 2bi ;
 149
 150 : infer-if ( -- )
 151     \ if combinator set
 152     2 literals-available? [
 153         (infer-if)
 154     ] [
 155         drop 2 ensure-d
 156         declare-if-effects
 157         2 shorten-d
 158         dup [ known curried/composed? ] any? [
 159             output-d
 160             [ rot [ drop call ] [ nip call ] if ]
 161             infer-quot-here
 162         ] [
 163             [ #drop, ] [ [ literal ] map (infer-if) ] bi
 164         ] if
 165     ] if ;
 166
 167 : infer-dispatch ( -- )
 168     \ dispatch combinator set
 169     pop-literal nip infer-branches
 170     [ #dispatch, ] dip compute-phi-function ;