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

View File

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

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.
USING: math kernel layouts system strings ;
USING: math kernel layouts system strings words quotations byte-arrays alien ;
IN: compiler.constants
! These constants must match vm/memory.h
@ -11,16 +11,15 @@ CONSTANT: deck-bits 18
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; 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
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell alien 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 object tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation 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
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline