basis/optimizer/allot/allot.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors sequences sequences.private classes.tuple
   4 classes.tuple.private kernel effects words quotations namespaces
   5 definitions math math.order layouts alien.accessors
   6 slots.private arrays byte-arrays inference.dataflow
   7 inference.known-words inference.state optimizer.inlining
   8 optimizer.backend ;
   9 IN: optimizer.allot
  10
  11 ! Expand memory allocation primitives into simpler constructs
  12 ! to simplify the backend.
  13
  14 : first-input ( #call -- obj ) dup in-d>> first node-literal ;
  15
  16 : (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
  17
  18 \ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
  19 \ (tuple) make-flushable
  20
  21 ! if the input to new is a literal tuple class, we can expand it
  22 : literal-new? ( #call -- ? )
  23     first-input tuple-class? ;
  24
  25 : new-quot ( class -- quot )
  26     dup all-slots 1 tail ! delegate slot
  27     [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
  28
  29 : expand-new ( #call -- node )
  30     dup first-input
  31     [ +inlined+ depends-on ] [ new-quot ] bi
  32     f splice-quot ;
  33
  34 \ new {
  35     { [ dup literal-new? ] [ expand-new ] }
  36 } define-optimizers
  37
  38 : tuple-boa-quot ( layout -- quot )
  39     [
  40         dup ,
  41         [ nip (tuple) ] %
  42         size>> 1 - [ 3 + ] map <reversed>
  43         [ [ set-slot ] curry [ keep ] curry % ] each
  44         [ f over 2 set-slot ] %
  45     ] [ ] make ;
  46
  47 : expand-tuple-boa ( #call -- node )
  48     dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
  49
  50 \ <tuple-boa> {
  51     { [ t ] [ expand-tuple-boa ] }
  52 } define-optimizers
  53
  54 : (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
  55
  56 \ (array) { integer } { array } <effect> set-primitive-effect
  57 \ (array) make-flushable
  58
  59 : <array>-quot ( n -- quot )
  60     [
  61         dup ,
  62         [ (array) ] %
  63         [ \ 2dup , , [ swap set-array-nth ] % ] each
  64         \ 2nip ,
  65     ] [ ] make ;
  66
  67 : literal-<array>? ( #call -- ? )
  68     first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
  69
  70 : expand-<array> ( #call -- node )
  71     dup first-input <array>-quot f splice-quot ;
  72
  73 \ <array> {
  74     { [ dup literal-<array>? ] [ expand-<array> ] }
  75 } define-optimizers
  76
  77 : (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
  78
  79 \ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
  80 \ (byte-array) make-flushable
  81
  82 : bytes>cells ( m -- n ) cell align cell /i ;
  83
  84 : <byte-array>-quot ( n -- quot )
  85     [
  86         dup ,
  87         [ nip (byte-array) ] %
  88         bytes>cells [ cell * ] map
  89         [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
  90     ] [ ] make ;
  91
  92 : literal-<byte-array>? ( #call -- ? )
  93     first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
  94
  95 : expand-<byte-array> ( #call -- node )
  96     dup first-input <byte-array>-quot f splice-quot ;
  97
  98 \ <byte-array> {
  99     { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
 100 } define-optimizers