101 lines
2.8 KiB
Factor
101 lines
2.8 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors sequences sequences.private classes.tuple
|
|
classes.tuple.private kernel effects words quotations namespaces
|
|
definitions math math.order layouts alien.accessors
|
|
slots.private arrays byte-arrays inference.dataflow
|
|
inference.known-words inference.state optimizer.inlining
|
|
optimizer.backend ;
|
|
IN: optimizer.allot
|
|
|
|
! Expand memory allocation primitives into simpler constructs
|
|
! to simplify the backend.
|
|
|
|
: first-input ( #call -- obj ) dup in-d>> first node-literal ;
|
|
|
|
: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
|
|
|
|
\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
|
|
\ (tuple) make-flushable
|
|
|
|
! if the input to new is a literal tuple class, we can expand it
|
|
: literal-new? ( #call -- ? )
|
|
first-input tuple-class? ;
|
|
|
|
: new-quot ( class -- quot )
|
|
dup all-slots 1 tail ! delegate slot
|
|
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
|
|
|
|
: expand-new ( #call -- node )
|
|
dup first-input
|
|
[ +inlined+ depends-on ] [ new-quot ] bi
|
|
f splice-quot ;
|
|
|
|
\ new {
|
|
{ [ dup literal-new? ] [ expand-new ] }
|
|
} define-optimizers
|
|
|
|
: tuple-boa-quot ( layout -- quot )
|
|
[
|
|
dup ,
|
|
[ nip (tuple) ] %
|
|
size>> 1 - [ 3 + ] map <reversed>
|
|
[ [ set-slot ] curry [ keep ] curry % ] each
|
|
[ f over 2 set-slot ] %
|
|
] [ ] make ;
|
|
|
|
: expand-tuple-boa ( #call -- node )
|
|
dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
|
|
|
|
\ <tuple-boa> {
|
|
{ [ t ] [ expand-tuple-boa ] }
|
|
} define-optimizers
|
|
|
|
: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
|
|
|
|
\ (array) { integer } { array } <effect> set-primitive-effect
|
|
\ (array) make-flushable
|
|
|
|
: <array>-quot ( n -- quot )
|
|
[
|
|
dup ,
|
|
[ (array) ] %
|
|
[ \ 2dup , , [ swap set-array-nth ] % ] each
|
|
\ 2nip ,
|
|
] [ ] make ;
|
|
|
|
: literal-<array>? ( #call -- ? )
|
|
first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
|
|
|
|
: expand-<array> ( #call -- node )
|
|
dup first-input <array>-quot f splice-quot ;
|
|
|
|
\ <array> {
|
|
{ [ dup literal-<array>? ] [ expand-<array> ] }
|
|
} define-optimizers
|
|
|
|
: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
|
|
|
|
\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
|
|
\ (byte-array) make-flushable
|
|
|
|
: bytes>cells ( m -- n ) cell align cell /i ;
|
|
|
|
: <byte-array>-quot ( n -- quot )
|
|
[
|
|
dup ,
|
|
[ nip (byte-array) ] %
|
|
bytes>cells [ cell * ] map
|
|
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
|
|
] [ ] make ;
|
|
|
|
: literal-<byte-array>? ( #call -- ? )
|
|
first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
|
|
|
|
: expand-<byte-array> ( #call -- node )
|
|
dup first-input <byte-array>-quot f splice-quot ;
|
|
|
|
\ <byte-array> {
|
|
{ [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
|
|
} define-optimizers
|