basis/stack-checker/branches/branches.factor

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