steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

bootstrap.image: remove some duplication from emit-object callers

db4
Slava Pestov 2009-04-29 23:35:02 -05:00
parent 7fae35c414
commit 3bbfc57de3
2 changed files with 20 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
basis/bootstrap/image/image.factor
View File

@ -247,8 +247,8 @@ SYMBOL: undefined-quot
: emit-fixnum ( n -- ) tag-fixnum emit ; : emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( header tag quot -- addr ) : emit-object ( class quot -- addr )
swap here-as [ swap tag-fixnum emit call align-here ] dip ; over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
inline inline
! Write an object to the image. ! Write an object to the image.
@ -293,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
M: bignum ' M: bignum '
[ [
bignum tag-number dup [ emit-bignum ] emit-object bignum [ emit-bignum ] emit-object
] cache-object ; ] cache-object ;
! Fixnums ! Fixnums
@ -316,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
M: float ' M: float '
[ [
float tag-number dup [ float [
align-here double>bits emit-64 align-here double>bits emit-64
] emit-object ] emit-object
] cache-object ; ] cache-object ;
@ -360,8 +360,7 @@ M: f '
} cleave } cleave
] { } make [ ' ] map ] { } make [ ' ] map
] bi ] bi
\ word type-number object tag-number \ word [ emit-seq ] emit-object
[ emit-seq ] emit-object
] keep put-object ; ] keep put-object ;
: word-error ( word msg -- * ) : word-error ( word msg -- * )
@ -382,8 +381,7 @@ M: word ' ;
! Wrappers ! Wrappers
M: wrapper ' M: wrapper '
wrapped>> ' wrapper type-number object tag-number wrapped>> ' wrapper [ emit ] emit-object ;
[ emit ] emit-object ;
! Strings ! Strings
: native> ( object -- object ) : native> ( object -- object )
@ -412,7 +410,7 @@ M: wrapper '
: emit-string ( string -- ptr ) : emit-string ( string -- ptr )
[ length ] [ extended-part ' ] [ ] tri [ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [ string [
[ emit-fixnum ] [ emit-fixnum ]
[ emit ] [ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ] [ f ' emit ascii-part pad-bytes emit-bytes ]
@ -429,12 +427,11 @@ M: string '
: emit-dummy-array ( obj type -- ptr ) : emit-dummy-array ( obj type -- ptr )
[ assert-empty ] [ [ assert-empty ] [
type-number object tag-number
[ 0 emit-fixnum ] emit-object [ 0 emit-fixnum ] emit-object
] bi* ; ] bi* ;
M: byte-array ' M: byte-array '
byte-array type-number object tag-number [ byte-array [
dup length emit-fixnum dup length emit-fixnum
pad-bytes emit-bytes pad-bytes emit-bytes
] emit-object ; ] emit-object ;
@ -448,7 +445,7 @@ ERROR: tuple-removed class ;
: (emit-tuple) ( tuple -- pointer ) : (emit-tuple) ( tuple -- pointer )
[ tuple-slots ] [ tuple-slots ]
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ; tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer ) : emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" = dup class name>> "tombstone" =
@ -463,8 +460,7 @@ M: tombstone '
! Arrays ! Arrays
: emit-array ( array -- offset ) : emit-array ( array -- offset )
[ ' ] map array type-number object tag-number [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ; M: array ' emit-array ;
@ -490,7 +486,7 @@ M: tuple-layout-array '
M: quotation ' M: quotation '
[ [
array>> ' array>> '
quotation type-number object tag-number [ quotation [
emit ! array emit ! array
f ' emit ! compiled f ' emit ! compiled
f ' emit ! cached-effect f ' emit ! cached-effect

19
basis/compiler/constants/constants.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings ; USING: math kernel layouts system strings words quotations byte-arrays alien ;
IN: compiler.constants IN: compiler.constants
! These constants must match vm/memory.h ! These constants must match vm/memory.h
@ -11,16 +11,15 @@ CONSTANT: deck-bits 18
! These constants must match vm/layouts.h ! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; inline : header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline : float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline : profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline : word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline