core/locals/rewrite/rewrite.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.tuple combinators
   4 fry.private hashtables kernel locals.backend locals.errors
   5 locals.types macros.expander make math memoize.private
   6 quotations sequences sets words ;
   7
   8 IN: locals.rewrite
   9
  10 DEFER: point-free
  11
  12 ! Step 1: rewrite [| into :> forms, turn
  13 ! literals with locals in them into code which constructs
  14 ! the literal after pushing locals on the stack
  15
  16 GENERIC: rewrite-sugar* ( obj -- )
  17
  18 : (rewrite-sugar) ( form -- form' )
  19     [ rewrite-sugar* ] [ ] make ;
  20
  21 GENERIC: quotation-rewrite ( form -- form' )
  22
  23 M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
  24
  25 : var-defs ( vars -- defs )
  26     [ [ ] ] [ <multi-def> 1quotation ] if-empty ;
  27
  28 M: lambda quotation-rewrite
  29     [ body>> ] [ vars>> var-defs ] bi prepend quotation-rewrite ;
  30
  31 M: callable rewrite-sugar* quotation-rewrite , ;
  32
  33 M: lambda rewrite-sugar* quotation-rewrite , ;
  34
  35 GENERIC: rewrite-literal? ( obj -- ? )
  36
  37 M: special rewrite-literal? drop t ;
  38
  39 M: sequence rewrite-literal? [ rewrite-literal? ] any? ;
  40
  41 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
  42
  43 M: hashtable rewrite-literal? >alist rewrite-literal? ;
  44
  45 M: tuple rewrite-literal? tuple>array rewrite-literal? ;
  46
  47 M: object rewrite-literal? drop f ;
  48
  49 GENERIC: rewrite-element ( obj -- )
  50
  51 : rewrite-elements ( seq -- )
  52     [ rewrite-element ] each ;
  53
  54 : rewrite-sequence ( seq -- )
  55     [ rewrite-elements ] [ length ] [ 0 head ] tri
  56     [ [nsequence] % ] [ [ like ] curry % ] bi ;
  57
  58 M: sequence rewrite-element
  59     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
  60
  61 M: hashtable rewrite-element
  62     dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
  63
  64 M: tuple rewrite-element
  65     dup rewrite-literal? [
  66         [ tuple-slots rewrite-elements ] [ class-of ] bi '[ _ boa ] %
  67     ] [ , ] if ;
  68
  69 M: quotation rewrite-element rewrite-sugar* ;
  70
  71 M: lambda rewrite-element rewrite-sugar* ;
  72
  73 M: let rewrite-element let-form-in-literal-error ;
  74
  75 M: local rewrite-element , ;
  76
  77 M: local-reader rewrite-element , ;
  78
  79 M: local-writer rewrite-element local-writer-in-literal-error ;
  80
  81 M: word rewrite-element <wrapper> , ;
  82
  83 : rewrite-wrapper ( wrapper -- )
  84     dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
  85
  86 M: wrapper rewrite-element
  87     rewrite-wrapper \ <wrapper> , ;
  88
  89 M: object rewrite-element , ;
  90
  91 M: sequence rewrite-sugar* rewrite-element ;
  92
  93 M: tuple rewrite-sugar* rewrite-element ;
  94
  95 M: multi-def rewrite-sugar* , ;
  96
  97 M: hashtable rewrite-sugar* rewrite-element ;
  98
  99 M: wrapper rewrite-sugar*
 100     rewrite-wrapper ;
 101
 102 M: word rewrite-sugar*
 103     dup { load-locals get-local drop-locals } member-eq?
 104     [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
 105
 106 M: object rewrite-sugar* , ;
 107
 108 M: let rewrite-sugar*
 109     body>> quotation-rewrite % ;
 110
 111 ! Step 2: identify free variables and make them into explicit
 112 ! parameters of lambdas which are curried on
 113
 114 GENERIC: rewrite-closures* ( obj -- )
 115
 116 : (rewrite-closures) ( form -- form' )
 117     [ [ rewrite-closures* ] each ] [ ] make ;
 118
 119 : rewrite-closures ( form -- form' )
 120     expand-macros (rewrite-sugar) (rewrite-closures) point-free ;
 121
 122 GENERIC: defs-vars* ( seq form -- seq' )
 123
 124 : defs-vars ( form -- vars ) { } [ defs-vars* ] reduce members ;
 125
 126 M: multi-def defs-vars* locals>> [ unquote suffix ] each ;
 127
 128 M: quotation defs-vars* [ defs-vars* ] each ;
 129
 130 M: object defs-vars* drop ;
 131
 132 GENERIC: uses-vars* ( seq form -- seq' )
 133
 134 : uses-vars ( form -- vars ) { } [ uses-vars* ] reduce members ;
 135
 136 M: local-writer uses-vars* "local-reader" word-prop suffix ;
 137
 138 M: lexical uses-vars* suffix ;
 139
 140 M: quote uses-vars* local>> uses-vars* ;
 141
 142 M: object uses-vars* drop ;
 143
 144 M: quotation uses-vars* [ uses-vars* ] each ;
 145
 146 : free-vars ( form -- seq )
 147     [ uses-vars ] [ defs-vars ] bi diff ;
 148
 149 M: callable rewrite-closures*
 150     ! Turn free variables into bound variables, curry them
 151     ! onto the body
 152     dup free-vars [ <quote> ] map
 153     [ % ]
 154     [ var-defs prepend (rewrite-closures) point-free , ]
 155     [ length \ curry <repetition> % ]
 156     tri ;
 157
 158 M: object rewrite-closures* , ;
 159
 160 ! Step 3: rewrite locals usage within a single quotation into
 161 ! retain stack manipulation
 162
 163 : local-index ( args obj -- n )
 164     2dup '[ unquote _ eq? ] find drop
 165     [ 2nip ] [ bad-local ] if* ;
 166
 167 : read-local-quot ( args obj -- quot )
 168     local-index neg [ get-local ] curry ;
 169
 170 GENERIC: localize ( args obj -- args quot )
 171
 172 M: local localize dupd read-local-quot ;
 173
 174 M: quote localize dupd local>> read-local-quot ;
 175
 176 M: local-reader localize dupd read-local-quot [ local-value ] append ;
 177
 178 M: local-writer localize
 179     dupd "local-reader" word-prop
 180     read-local-quot [ set-local-value ] append ;
 181
 182 M: multi-def localize
 183     locals>> <reversed>
 184     [ prepend ]
 185     [ [ [ local-reader? ] dip '[ [ 1array ] _ [ndip] ] [ [ ] ] if ] map-index concat ]
 186     [
 187         length {
 188             { [ dup 1 > ] [ [ load-locals ] curry ] }
 189             { [ dup 1 = ] [ drop [ load-local ] ] }
 190             [ drop [ ] ]
 191         } cond
 192     ] tri append ;
 193
 194 M: object localize 1quotation ;
 195
 196 : drop-locals-quot ( args -- )
 197     [ length , [ drop-locals ] % ] unless-empty ;
 198
 199 : point-free ( quot -- newquot )
 200     [ { } swap [ localize % ] each drop-locals-quot ] [ ] make ;