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

rewrote fixnum intrinsics, and added eq? type intrinsics

cvs
Slava Pestov 2005-05-08 02:39:00 +00:00
parent ec393e6dee
commit 124ee9ef16
22 changed files with 684 additions and 533 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
doc/handbook.tex
View File

@ -741,8 +741,8 @@ as the next word in the quotation would expect them. Their behavior can be under
\wordtable{ \wordtable{
\vocabulary{kernel} \vocabulary{kernel}
\ordinaryword{drop}{drop ( x -- )} \ordinaryword{drop}{drop ( x -- )}
\ordinaryword{2drop}{drop ( x y -- )} \ordinaryword{2drop}{2drop ( x y -- )}
\ordinaryword{3drop}{drop ( x y z -- )} \ordinaryword{3drop}{3drop ( x y z -- )}
\ordinaryword{nip}{nip ( x y -- y )} \ordinaryword{nip}{nip ( x y -- y )}
\ordinaryword{2nip}{2nip ( x y -- y )} \ordinaryword{2nip}{2nip ( x y -- y )}
\ordinaryword{dup}{dup ( x -- x x )} \ordinaryword{dup}{dup ( x -- x x )}

23
library/bootstrap/boot-stage1.factor
View File

@ -63,29 +63,6 @@ hashtables ;
"/library/tools/gensym.factor" "/library/tools/gensym.factor"
"/library/tools/interpreter.factor" "/library/tools/interpreter.factor"
"/library/tools/memory.factor" "/library/tools/memory.factor"
"/library/inference/conditions.factor"
"/library/inference/dataflow.factor"
"/library/inference/inference.factor"
"/library/inference/ties.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/types.factor"
"/library/compiler/assembler.factor"
"/library/compiler/relocate.factor"
"/library/compiler/xt.factor"
"/library/compiler/optimizer.factor"
"/library/compiler/linearizer.factor"
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
"/library/alien/dataflow.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
] pull-in ] pull-in
"delegate" [ "generic" ] search "delegate" [ "generic" ] search

65
library/bootstrap/boot-stage2.factor
View File

@ -24,19 +24,42 @@ recrossref
drop drop
] ifte ; ] ifte ;
! These are loaded here until bootstrap gets some fixes "Loading compiler and friends..." print
t [ t [
"/library/inference/conditions.factor"
"/library/inference/dataflow.factor"
"/library/inference/inference.factor"
"/library/inference/ties.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/types.factor"
"/library/compiler/assembler.factor"
"/library/compiler/relocate.factor"
"/library/compiler/xt.factor"
"/library/compiler/optimizer.factor"
"/library/compiler/vops.factor"
"/library/compiler/linearizer.factor"
"/library/compiler/intrinsics.factor"
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
"/library/alien/dataflow.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
"/library/alien/compiler.factor" "/library/alien/compiler.factor"
"/library/alien/malloc.factor" "/library/alien/malloc.factor"
"/library/io/buffer.factor" "/library/io/buffer.factor"
] pull-in ] pull-in
"Loading compiler backend..." print
cpu "x86" = [ cpu "x86" = [
"/library/compiler/x86/assembler.factor" "/library/compiler/x86/assembler.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/generator.factor" "/library/compiler/x86/generator.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/fixnum.factor" "/library/compiler/x86/fixnum.factor"
"/library/compiler/x86/alien.factor" "/library/compiler/x86/alien.factor"
] pull-in ] pull-in
@ -48,38 +71,4 @@ cpu "ppc" = [
"/library/compiler/ppc/alien.factor" "/library/compiler/ppc/alien.factor"
] pull-in ] pull-in
"Compiling base..." print
unix? [
"sdl" "libSDL.so" "cdecl" add-library
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
] when
win32? [
"kernel32" "kernel32.dll" "stdcall" add-library
"user32" "user32.dll" "stdcall" add-library
"gdi32" "gdi32.dll" "stdcall" add-library
"winsock" "ws2_32.dll" "stdcall" add-library
"mswsock" "mswsock.dll" "stdcall" add-library
"libc" "msvcrt.dll" "cdecl" add-library
"sdl" "SDL.dll" "cdecl" add-library
"sdl-gfx" "SDL_gfx.dll" "cdecl" add-library
"sdl-ttf" "SDL_ttf.dll" "cdecl" add-library
] when
default-cli-args
parse-command-line
init-assembler
: compile? "compile" get supported-cpu? and ;
compile? [
\ car compile
\ length compile
\ = compile
\ unparse compile
\ scan compile
] when
"/library/bootstrap/boot-stage3.factor" run-resource "/library/bootstrap/boot-stage3.factor" run-resource

36
library/bootstrap/boot-stage3.factor
View File

@ -3,7 +3,41 @@
USING: alien assembler command-line compiler io-internals kernel USING: alien assembler command-line compiler io-internals kernel
lists namespaces parser sequences stdio unparser words ; lists namespaces parser sequences stdio unparser words ;
"Bootstrap stage 3..." print "Compiling base..." print
unix? [
"sdl" "libSDL.so" "cdecl" add-library
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
] when
win32? [
"kernel32" "kernel32.dll" "stdcall" add-library
"user32" "user32.dll" "stdcall" add-library
"gdi32" "gdi32.dll" "stdcall" add-library
"winsock" "ws2_32.dll" "stdcall" add-library
"mswsock" "mswsock.dll" "stdcall" add-library
"libc" "msvcrt.dll" "cdecl" add-library
"sdl" "SDL.dll" "cdecl" add-library
"sdl-gfx" "SDL_gfx.dll" "cdecl" add-library
"sdl-ttf" "SDL_ttf.dll" "cdecl" add-library
] when
default-cli-args
parse-command-line
init-assembler
: compile? "compile" get supported-cpu? and ;
compile? [
\ car compile
\ length compile
\ = compile
\ unparse compile
\ scan compile
] when
"Loading more library code..." print
t [ t [
"/library/math/constants.factor" "/library/math/constants.factor"

11
library/compiler/generator.factor
View File

@ -1,10 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
DEFER: compile-call-label ( label -- )
DEFER: compile-jump-label ( label -- )
IN: compiler IN: compiler
USING: assembler errors inference kernel lists math namespaces USING: assembler errors inference kernel lists math namespaces
sequences strings vectors words ; sequences strings vectors words ;
@ -52,12 +47,6 @@ M: %label generate-node ( vop -- )
M: %end-dispatch generate-node ( vop -- ) drop ; M: %end-dispatch generate-node ( vop -- ) drop ;
: compile-call ( word -- ) dup postpone-word compile-call-label ;
M: %call generate-node vop-label compile-call ;
M: %jump-label generate-node vop-label compile-jump-label ;
: compile-target ( word -- ) 0 compile-cell absolute ; : compile-target ( word -- ) 0 compile-cell absolute ;
M: %target-label generate-node vop-label compile-target ; M: %target-label generate-node vop-label compile-target ;

88
library/compiler/intrinsics.factor
View File

@ -35,8 +35,8 @@ words ;
\ swap [ \ swap [
drop drop
in-2 in-2
1 0 %replace-d , 0 0 %replace-d ,
0 1 %replace-d , 1 1 %replace-d ,
] "linearizer" set-word-prop ] "linearizer" set-word-prop
\ over [ \ over [
@ -97,7 +97,7 @@ words ;
drop drop
in-2 in-2
1 %dec-d , 1 %dec-d ,
1 %untag , 0 %untag ,
1 0 %slot , 1 0 %slot ,
] ifte out-1 ] ifte out-1
] "linearizer" set-word-prop ] "linearizer" set-word-prop
@ -110,13 +110,13 @@ words ;
1 %dec-d , 1 %dec-d ,
in-2 in-2
2 %dec-d , 2 %dec-d ,
slot@ >r 1 0 r> %fast-set-slot , slot@ >r 0 1 r> %fast-set-slot ,
] [ ] [
drop drop
in-3 in-3
3 %dec-d , 3 %dec-d ,
1 %untag , 1 %untag ,
2 1 0 %set-slot , 0 1 2 %set-slot ,
] ifte ] ifte
] "linearizer" set-word-prop ] "linearizer" set-word-prop
@ -126,43 +126,93 @@ words ;
drop drop
in-1 in-1
0 %type , 0 %type ,
0 %tag-fixnum ,
out-1 out-1
] "linearizer" set-word-prop ] "linearizer" set-word-prop
: binary-op-reg ( op -- ) \ arithmetic-type intrinsic
in-2
<< vreg f 1 >> << vreg f 0 >> rot execute , \ arithmetic-type [
drop
in-1
0 %arithmetic-type ,
0 %tag-fixnum ,
out-1
] "linearizer" set-word-prop
: binary-op-reg ( op out -- )
>r in-2
1 <vreg> 0 <vreg> rot execute ,
1 %dec-d , 1 %dec-d ,
out-1 ; r> 0 %replace-d , ;
: binary-op ( node op out -- )
: binary-op ( node op -- ) #! out is a vreg where the vop stores the result.
node-consume-d rot hash >r >r node-consume-d swap hash
dup top-literal? [ dup top-literal? [
1 %dec-d , 1 %dec-d ,
in-1 in-1
peek literal-value << vreg f 0 >> rot execute , peek literal-value 0 <vreg> r> execute ,
out-1 r> 0 %replace-d ,
] [ ] [
drop drop
binary-op-reg r> r> binary-op-reg
] ifte ; ] ifte ;
[ [
[[ fixnum+ %fixnum+ ]] [[ fixnum+ %fixnum+ ]]
[[ fixnum- %fixnum- ]] [[ fixnum- %fixnum- ]]
[[ fixnum* %fixnum* ]]
[[ fixnum-mod %fixnum-mod ]]
[[ fixnum-bitand %fixnum-bitand ]] [[ fixnum-bitand %fixnum-bitand ]]
[[ fixnum-bitor %fixnum-bitor ]] [[ fixnum-bitor %fixnum-bitor ]]
[[ fixnum-bitxor %fixnum-bitxor ]] [[ fixnum-bitxor %fixnum-bitxor ]]
[[ fixnum/i %fixnum/i ]] [[ fixnum-shift %fixnum-shift ]]
[[ fixnum<= %fixnum<= ]] [[ fixnum<= %fixnum<= ]]
[[ fixnum< %fixnum< ]] [[ fixnum< %fixnum< ]]
[[ fixnum>= %fixnum>= ]] [[ fixnum>= %fixnum>= ]]
[[ fixnum> %fixnum> ]] [[ fixnum> %fixnum> ]]
] [ ] [
uncons over intrinsic uncons over intrinsic
[ literal, \ binary-op , ] make-list [ literal, 0 , \ binary-op , ] make-list
"linearizer" set-word-prop "linearizer" set-word-prop
] each ] each
\ fixnum* intrinsic
\ fixnum* [
drop \ %fixnum* 0 binary-op-reg
] "linearizer" set-word-prop
\ fixnum-mod intrinsic
\ fixnum-mod [
! This is not clever. Because of x86, %fixnum-mod is
! hard-coded to put its output in vreg 2, which happends to
! be EDX there.
drop \ %fixnum-mod 2 binary-op-reg
] "linearizer" set-word-prop
\ fixnum/i intrinsic
\ fixnum/i [
drop \ %fixnum/i 0 binary-op-reg
] "linearizer" set-word-prop
\ fixnum/mod intrinsic
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
drop
in-2
0 <vreg> 1 <vreg> %fixnum/mod ,
2 0 %replace-d ,
0 1 %replace-d ,
] "linearizer" set-word-prop
\ fixnum-bitnot intrinsic
\ fixnum-bitnot [
drop
in-1
0 %fixnum-bitnot ,
out-1
] "linearizer" set-word-prop

294
library/compiler/simplifier.factor
View File

@ -4,150 +4,152 @@ IN: compiler
USING: inference kernel lists math namespaces prettyprint USING: inference kernel lists math namespaces prettyprint
strings words ; strings words ;
: simplify ;
! The linear IR being simplified is stored in this variable. ! The linear IR being simplified is stored in this variable.
SYMBOL: simplifying ! SYMBOL: simplifying
!
: simplifiers ( linear -- list ) ! : simplifiers ( linear -- list )
#! A list of quotations with stack effect ! #! A list of quotations with stack effect
#! ( linear -- linear ? ) that can simplify the first node ! #! ( linear -- linear ? ) that can simplify the first node
#! in the linear IR. ! #! in the linear IR.
car car "simplifiers" word-prop ; ! car car "simplifiers" word-prop ;
!
: simplify-node ( linear list -- linear ? ) ! : simplify-node ( linear list -- linear ? )
dup [ ! dup [
uncons >r call [ ! uncons >r call [
r> drop t ! r> drop t
] [ ! ] [
r> simplify-node ! r> simplify-node
] ifte ! ] ifte
] when ; ! ] when ;
!
: simplify-1 ( linear -- linear ? ) ! : simplify-1 ( linear -- linear ? )
#! Return a new linear IR. ! #! Return a new linear IR.
dup [ ! dup [
dup simplifiers simplify-node ! dup simplifiers simplify-node
[ uncons simplify-1 drop cons t ] ! [ uncons simplify-1 drop cons t ]
[ uncons simplify-1 >r cons r> ] ifte ! [ uncons simplify-1 >r cons r> ] ifte
] [ ! ] [
f ! f
] ifte ; ! ] ifte ;
!
: simplify ( linear -- linear ) ! : simplify ( linear -- linear )
#! Keep simplifying until simplify-1 returns f. ! #! Keep simplifying until simplify-1 returns f.
[ ! [
dup simplifying set simplify-1 ! dup simplifying set simplify-1
] with-scope [ simplify ] when ; ! ] with-scope [ simplify ] when ;
!
: label-called? ( label linear -- ? ) ! : label-called? ( label linear -- ? )
[ uncons pick = swap #label = not and ] some? nip ; ! [ uncons pick = swap #label = not and ] some? nip ;
!
#label [ ! #label [
[ ! [
dup car cdr simplifying get label-called? ! dup car cdr simplifying get label-called?
[ f ] [ cdr t ] ifte ! [ f ] [ cdr t ] ifte
] ! ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
: next-physical? ( op linear -- ? ) ! : next-physical? ( op linear -- ? )
cdr dup [ car car = ] [ 2drop f ] ifte ; ! cdr dup [ car car = ] [ 2drop f ] ifte ;
!
: cancel ( linear op -- linear param ? ) ! : cancel ( linear op -- linear param ? )
#! If the following op is as given, remove it, and return ! #! If the following op is as given, remove it, and return
#! its param. ! #! its param.
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ; ! over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
!
\ drop [ ! \ drop [
[ ! [
#push-immediate cancel [ ! #push-immediate cancel [
#replace-immediate swons swons t ! #replace-immediate swons swons t
] when ! ] when
] [ ! ] [
#push-indirect cancel [ ! #push-indirect cancel [
#replace-indirect swons swons t ! #replace-indirect swons swons t
] when ! ] when
] ! ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
: find-label ( label -- rest ) ! : find-label ( label -- rest )
simplifying get [ ! simplifying get [
uncons pick = swap #label = and ! uncons pick = swap #label = and
] some? nip ; ! ] some? nip ;
!
: next-logical ( linear -- linear ) ! : next-logical ( linear -- linear )
dup car car "next-logical" word-prop call ; ! dup car car "next-logical" word-prop call ;
!
#label [ ! #label [
cdr next-logical ! cdr next-logical
] "next-logical" set-word-prop ! ] "next-logical" set-word-prop
!
#jump-label [ ! #jump-label [
car cdr find-label cdr ! car cdr find-label cdr
] "next-logical" set-word-prop ! ] "next-logical" set-word-prop
!
#target-label [ ! #target-label [
car cdr find-label cdr ! car cdr find-label cdr
] "next-logical" set-word-prop ! ] "next-logical" set-word-prop
!
: next-logical? ( op linear -- ? ) ! : next-logical? ( op linear -- ? )
next-logical dup [ car car = ] [ 2drop f ] ifte ; ! next-logical dup [ car car = ] [ 2drop f ] ifte ;
!
: reduce ( linear op new -- linear ? ) ! : reduce ( linear op new -- linear ? )
>r over cdr next-logical? [ ! >r over cdr next-logical? [
unswons cdr r> swons swons t ! unswons cdr r> swons swons t
] [ ! ] [
r> drop f ! r> drop f
] ifte ; ! ] ifte ;
!
#call [ ! #call [
[ #return #jump reduce ] ! [ #return #jump reduce ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
#call-label [ ! #call-label [
[ #return #jump-label reduce ] ! [ #return #jump-label reduce ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
: double-jump ( linear op1 op2 -- linear ? ) ! : double-jump ( linear op1 op2 -- linear ? )
#! A jump to a jump is just a jump. If the next logical node ! #! A jump to a jump is just a jump. If the next logical node
#! is a jump of type op1, replace the jump at the car of the ! #! is a jump of type op1, replace the jump at the car of the
#! list with a jump of type op2. ! #! list with a jump of type op2.
swap pick next-logical? [ ! swap pick next-logical? [
over next-logical car cdr cons swap cdr cons t ! over next-logical car cdr cons swap cdr cons t
] [ ! ] [
drop f ! drop f
] ifte ; ! ] ifte ;
!
: useless-jump ( linear -- linear ? ) ! : useless-jump ( linear -- linear ? )
#! A jump to a label immediately following is not needed. ! #! A jump to a label immediately following is not needed.
dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ; ! dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
!
: (dead-code) ( linear -- linear ? ) ! : (dead-code) ( linear -- linear ? )
#! Remove all nodes until the next #label. ! #! Remove all nodes until the next #label.
dup [ ! dup [
dup car car #label = [ ! dup car car #label = [
f ! f
] [ ! ] [
cdr (dead-code) t or ! cdr (dead-code) t or
] ifte ! ] ifte
] [ ! ] [
f ! f
] ifte ; ! ] ifte ;
!
: dead-code ( linear -- linear ? ) ! : dead-code ( linear -- linear ? )
uncons (dead-code) >r cons r> ; ! uncons (dead-code) >r cons r> ;
!
#jump-label [ ! #jump-label [
[ #return #return double-jump ] ! [ #return #return double-jump ]
[ #jump-label #jump-label double-jump ] ! [ #jump-label #jump-label double-jump ]
[ #jump #jump double-jump ] ! [ #jump #jump double-jump ]
[ useless-jump ] ! [ useless-jump ]
[ dead-code ] ! [ dead-code ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
#target-label [ ! #target-label [
[ #jump-label #target-label double-jump ] ! [ #jump-label #target-label double-jump ]
! [ #jump #target double-jump ] ! ! [ #jump #target double-jump ]
] "simplifiers" set-word-prop ! ] "simplifiers" set-word-prop
!
#jump [ [ dead-code ] ] "simplifiers" set-word-prop ! #jump [ [ dead-code ] ] "simplifiers" set-word-prop
#return [ [ dead-code ] ] "simplifiers" set-word-prop ! #return [ [ dead-code ] ] "simplifiers" set-word-prop
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop ! #end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop

38
library/compiler/vops.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: compiler IN: compiler
USING: generic kernel namespaces parser ; USING: errors generic kernel namespaces parser ;
! The linear IR is the second of the two intermediate ! The linear IR is the second of the two intermediate
! representations used by Factor. It is basically a high-level ! representations used by Factor. It is basically a high-level
@ -28,6 +28,7 @@ GENERIC: generate-node ( vop -- )
: label-vop ( label) >r f f f r> ; : label-vop ( label) >r f f f r> ;
: label/src-vop ( label src) swap >r f f r> ; : label/src-vop ( label src) swap >r f f r> ;
: src-vop ( src) f f f ; : src-vop ( src) f f f ;
: dest-vop ( dest) f swap f f ;
: src/dest-vop ( src dest) f f ; : src/dest-vop ( src dest) f f ;
! miscellanea ! miscellanea
@ -84,10 +85,9 @@ VOP: %inc-r
: %inc-r ( n -- ) >r f f r> f <%inc-r> ; : %inc-r ( n -- ) >r f f r> f <%inc-r> ;
: in-1 0 0 %peek-d , ; : in-1 0 0 %peek-d , ;
: in-2 in-1 1 1 %peek-d , ; : in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 in-2 2 2 %peek-d , ; : in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
: out-1 0 0 %replace-d , ; : out-1 0 0 %replace-d , ;
: out-2 out-1 1 1 %replace-d , ;
! indirect load of a literal through a table ! indirect load of a literal through a table
VOP: %indirect VOP: %indirect
@ -95,9 +95,9 @@ VOP: %indirect
! object slot accessors ! object slot accessors
VOP: %untag VOP: %untag
: %untag <vreg> src-vop <%untag> ; : %untag <vreg> dest-vop <%untag> ;
VOP: %slot VOP: %slot
: %slot ( vreg n ) >r >r f r> <vreg> r> <vreg> f <%slot> ; : %slot ( n vreg ) >r <vreg> r> <vreg> f f <%slot> ;
VOP: %set-slot VOP: %set-slot
: %set-slot ( vreg:value vreg:obj n ) : %set-slot ( vreg:value vreg:obj n )
@ -111,20 +111,36 @@ VOP: %fast-set-slot
: %fast-set-slot ( vreg:value vreg:obj n ) : %fast-set-slot ( vreg:value vreg:obj n )
>r >r <vreg> r> <vreg> r> f <%fast-set-slot> ; >r >r <vreg> r> <vreg> r> f <%fast-set-slot> ;
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> src-vop <%type> ;
! fixnum intrinsics ! fixnum intrinsics
VOP: %fixnum+ : %fixnum+ src/dest-vop <%fixnum+> ; VOP: %fixnum+ : %fixnum+ src/dest-vop <%fixnum+> ;
VOP: %fixnum- : %fixnum- src/dest-vop <%fixnum-> ; VOP: %fixnum- : %fixnum- src/dest-vop <%fixnum-> ;
VOP: %fixnum* : %fixnum* src/dest-vop <%fixnum*> ; VOP: %fixnum* : %fixnum* src/dest-vop <%fixnum*> ;
VOP: %fixnum-mod : %fixnum-mod src/dest-vop <%fixnum-mod> ; VOP: %fixnum-mod : %fixnum-mod src/dest-vop <%fixnum-mod> ;
VOP: %fixnum/i : %fixnum/i src/dest-vop <%fixnum/i> ;
VOP: %fixnum/mod : %fixnum/mod src/dest-vop <%fixnum/mod> ;
VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ; VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ;
VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ; VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ; VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
VOP: %fixnum/i : %fixnum/i src/dest-vop <%fixnum/i> ; VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
VOP: %fixnum-shift : %fixnum-shift src/dest-vop <%fixnum-shift> ;
VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ; VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ; VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ; VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ; VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ;
VOP: %eq? : %eq? src/dest-vop <%eq?> ;
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> dest-vop <%type> ;
VOP: %arithmetic-type
: %arithmetic-type empty-vop <%arithmetic-type> ;
VOP: %tag-fixnum
: %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
: check-dest ( vop reg -- )
swap vop-dest v>operand = [
"invalid VOP destination" throw
] unless ;

2
library/compiler/x86/alien.factor
View File

@ -5,7 +5,7 @@ USING: alien assembler inference kernel kernel-internals lists
math memory namespaces words ; math memory namespaces words ;
\ alien-invoke [ \ alien-invoke [
uncons load-library 2dup dlsym CALL t rel-dlsym uncons load-library compile-c-call
] "generator" set-word-prop ] "generator" set-word-prop
\ alien-global [ \ alien-global [

89
library/compiler/x86/assembler.factor
View File

@ -1,30 +1,5 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USE: compiler USE: compiler
IN: assembler IN: assembler
USE: words USE: words
@ -210,30 +185,35 @@ M: operand MOV HEX: 89 2-operand ;
GENERIC: JMP ( op -- ) GENERIC: JMP ( op -- )
M: integer JMP HEX: e9 compile-byte from compile-cell ; M: integer JMP HEX: e9 compile-byte from compile-cell ;
M: operand JMP HEX: ff compile-byte BIN: 100 1-operand ; M: operand JMP HEX: ff compile-byte BIN: 100 1-operand ;
M: word JMP 0 JMP relative ;
GENERIC: CALL ( op -- ) GENERIC: CALL ( op -- )
M: integer CALL HEX: e8 compile-byte from compile-cell ; M: integer CALL HEX: e8 compile-byte from compile-cell ;
M: operand CALL HEX: ff compile-byte BIN: 010 1-operand ; M: operand CALL HEX: ff compile-byte BIN: 010 1-operand ;
M: word CALL 0 CALL relative ;
: JUMPcc ( addr opcode -- ) GENERIC: JUMPcc ( opcode addr -- )
HEX: 0f compile-byte compile-byte from compile-cell ; M: integer JUMPcc ( opcode addr -- )
HEX: 0f compile-byte swap compile-byte from compile-cell ;
M: word JUMPcc ( opcode addr -- )
>r 0 JUMPcc r> relative ;
: JO HEX: 80 JUMPcc ; : JO HEX: 80 swap JUMPcc ;
: JNO HEX: 81 JUMPcc ; : JNO HEX: 81 swap JUMPcc ;
: JB HEX: 82 JUMPcc ; : JB HEX: 82 swap JUMPcc ;
: JAE HEX: 83 JUMPcc ; : JAE HEX: 83 swap JUMPcc ;
: JE HEX: 84 JUMPcc ; : JE HEX: 84 swap JUMPcc ;
: JNE HEX: 85 JUMPcc ; : JNE HEX: 85 swap JUMPcc ;
: JBE HEX: 86 JUMPcc ; : JBE HEX: 86 swap JUMPcc ;
: JA HEX: 87 JUMPcc ; : JA HEX: 87 swap JUMPcc ;
: JS HEX: 88 JUMPcc ; : JS HEX: 88 swap JUMPcc ;
: JNS HEX: 89 JUMPcc ; : JNS HEX: 89 swap JUMPcc ;
: JP HEX: 8a JUMPcc ; : JP HEX: 8a swap JUMPcc ;
: JNP HEX: 8b JUMPcc ; : JNP HEX: 8b swap JUMPcc ;
: JL HEX: 8c JUMPcc ; : JL HEX: 8c swap JUMPcc ;
: JGE HEX: 8d JUMPcc ; : JGE HEX: 8d swap JUMPcc ;
: JLE HEX: 8e JUMPcc ; : JLE HEX: 8e swap JUMPcc ;
: JG HEX: 8f JUMPcc ; : JG HEX: 8f swap JUMPcc ;
: RET ( -- ) HEX: c3 compile-byte ; : RET ( -- ) HEX: c3 compile-byte ;
@ -271,21 +251,20 @@ GENERIC: CMP ( dst src -- )
M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ; M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ;
M: operand CMP OCT: 071 2-operand ; M: operand CMP OCT: 071 2-operand ;
: IMUL ( dst src -- ) : NOT ( dst -- ) HEX: f7 compile-byte BIN: 010 1-operand ;
HEX: 0f compile-byte HEX: af 2-operand ; : NEG ( dst -- ) HEX: f7 compile-byte BIN: 011 1-operand ;
: MUL ( dst -- ) HEX: f7 compile-byte BIN: 100 1-operand ;
: IDIV ( src -- ) : IMUL ( src -- ) HEX: f7 compile-byte BIN: 101 1-operand ;
#! IDIV is weird on x86. Only the divisor is given as an : DIV ( dst -- ) HEX: f7 compile-byte BIN: 110 1-operand ;
#! explicit operand. The quotient is stored in EAX, the : IDIV ( src -- ) HEX: f7 compile-byte BIN: 111 1-operand ;
#! remainder in EDX.
HEX: f7 compile-byte BIN: 111 1-operand ;
: CDQ HEX: 99 compile-byte ; : CDQ HEX: 99 compile-byte ;
: SHL ( dst src -- ) HEX: c1 BIN: 100 immediate-8 ; : SHL ( dst n -- ) HEX: c1 BIN: 100 immediate-8 ;
: SHR ( dst n -- ) HEX: c1 BIN: 101 immediate-8 ;
: SHR ( dst src -- ) HEX: c1 BIN: 101 immediate-8 ; : SAR ( dst n -- ) HEX: c1 BIN: 111 immediate-8 ;
: RCR ( dst -- ) HEX: d1 compile-byte BIN: 011 1-operand ;
: LEA ( dst src -- ) : LEA ( dst src -- )
HEX: 8d compile-byte swap register 1-operand ; HEX: 8d compile-byte swap register 1-operand ;

268
library/compiler/x86/fixnum.factor
View File

@ -1,157 +1,153 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler IN: compiler
USE: assembler USING: assembler errors kernel math math-internals memory
USE: inference namespaces words ;
USE: math
USE: words
USE: kernel
USE: alien
USE: lists
USE: math-internals
! This file provides compiling definitions for fixnum words : dest/src ( vop -- dest src )
! that are faster than what C gives us. There is a lot of dup vop-dest v>operand swap vop-source v>operand ;
! code repetition here. It will be factored out at the same
! time as rewriting the code to use registers for intermediate
! values happends. At this point in time, this is just a
! prototype to test the assembler.
: fixnum-insn ( overflow opcode -- ) : simple-overflow ( dest -- )
#! This needs to be factored. #! If the previous arithmetic operation overflowed, then we
EAX [ ESI -4 ] MOV #! turn the result into a bignum and leave it in EAX. This
EAX [ ESI ] rot execute #! does not trigger a GC if memory is full -- is that bad?
0 JNO just-compiled <label> "end" set
swap compile-call "end" get JNO
0 JMP just-compiled >r ! There was an overflow. Untag the fixnum and add the carry.
compiled-offset swap patch ! Thanks to Dazhbog for figuring out this trick.
ESI 4 SUB dup RCR
[ ESI ] EAX MOV dup 2 SAR
r> compiled-offset swap patch ; ! Create a bignum
PUSH
"s48_long_to_bignum" f compile-c-call
! An untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP 4 ADD
"end" get save-xt ;
\ fixnum+ [ M: %fixnum+ generate-node ( vop -- )
drop \ fixnum+ \ ADD fixnum-insn dest/src dupd ADD simple-overflow ;
] "generator" set-word-prop
\ fixnum+ [ \ fixnum+ self ] "infer" set-word-prop M: %fixnum- generate-node ( vop -- )
dest/src dupd SUB simple-overflow ;
\ fixnum- [ M: %fixnum* generate-node ( vop -- )
drop \ fixnum- \ SUB fixnum-insn
] "generator" set-word-prop
\ fixnum- [ \ fixnum- self ] "infer" set-word-prop
\ fixnum* [
drop drop
EAX [ ESI -4 ] MOV ! both inputs are tagged, so one of them needs to have its
EAX 3 SHR ! tag removed.
EAX [ ESI ] IMUL EAX tag-bits SAR
0 JNO just-compiled ECX IMUL
\ fixnum* compile-call <label> "end" set
0 JMP just-compiled >r "end" get JNO
compiled-offset swap patch ! make a bignum
ESI 4 SUB EDX PUSH
[ ESI ] EAX MOV EAX PUSH
r> compiled-offset swap patch "s48_long_long_to_bignum" f compile-c-call
] "generator" set-word-prop ESP 8 ADD
! now we have to shift it by three bits to remove the second
! tag
tag-bits neg PUSH
EAX PUSH
"s48_bignum_arithmetic_shift" f compile-c-call
! an untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP 8 ADD
"end" get save-xt ;
\ fixnum* [ \ fixnum* self ] "infer" set-word-prop M: %fixnum-mod generate-node ( vop -- )
#! This has specific register requirements. Inputs are in
\ fixnum/i [ #! EAX and ECX, and the result is in EDX.
drop drop
EAX [ ESI -4 ] MOV
CDQ CDQ
[ ESI ] IDIV ECX IDIV ;
EAX 3 SHL
0 JNO just-compiled
\ fixnum/i compile-call
0 JMP just-compiled >r
compiled-offset swap patch
ESI 4 SUB
[ ESI ] EAX MOV
r> compiled-offset swap patch
] "generator" set-word-prop
\ fixnum/i [ \ fixnum/i self ] "infer" set-word-prop : generate-fixnum/mod
#! The same code is used for %fixnum/i and %fixnum/mod.
\ fixnum-mod [ #! This has specific register requirements. Inputs are in
#! EAX and ECX, and the result is in EDX.
<label> "end" set
drop drop
EAX [ ESI -4 ] MOV
CDQ CDQ
[ ESI ] IDIV ECX IDIV
! Make a copy since following shift is destructive
ECX EAX MOV
! Tag the value, since division cancelled tags from both
! inputs
EAX 3 SHL EAX 3 SHL
0 JNO just-compiled ! Did it overflow?
\ fixnum/i compile-call "end" get JNO
0 JMP just-compiled >r ! There was an overflow, so make ECX into a bignum. we must
compiled-offset swap patch ! save EDX since its volatile.
ESI 4 SUB EDX PUSH
[ ESI ] EDX MOV ECX PUSH
r> compiled-offset swap patch "s48_long_to_bignum" f compile-c-call
] "generator" set-word-prop ! An untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP 4 ADD
! the remainder is now in EDX
EDX POP
"end" get save-xt ;
\ fixnum-mod [ \ fixnum-mod self ] "infer" set-word-prop M: %fixnum/i generate-node generate-fixnum/mod ;
\ fixnum/mod [ M: %fixnum/mod generate-node generate-fixnum/mod ;
drop
EAX [ ESI -4 ] MOV
CDQ
[ ESI ] IDIV
EAX 3 SHL
0 JNO just-compiled
\ fixnum/mod compile-call
0 JMP just-compiled >r
compiled-offset swap patch
[ ESI -4 ] EAX MOV
[ ESI ] EDX MOV
r> compiled-offset swap patch
] "generator" set-word-prop
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop M: %fixnum-bitand generate-node ( vop -- ) dest/src AND ;
: PUSH-DS ( -- ) M: %fixnum-bitor generate-node ( vop -- ) dest/src OR ;
#! Push EAX to datastack.
ESI 4 ADD
[ ESI ] EAX MOV ;
\ arithmetic-type [ M: %fixnum-bitxor generate-node ( vop -- ) dest/src XOR ;
drop
EAX [ ESI -4 ] MOV
EAX BIN: 111 AND
EDX [ ESI ] MOV
EDX BIN: 111 AND
EAX EDX CMP
0 JE just-compiled >r
\ arithmetic-type compile-call
0 JMP just-compiled
compiled-offset r> patch
EAX 3 SHL
PUSH-DS
compiled-offset swap patch
] "generator" set-word-prop
\ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-prop M: %fixnum-bitnot generate-node ( vop -- )
! Negate the bits of the operand
vop-dest v>operand dup NOT
! Mask off the low 3 bits to give a fixnum tag
tag-mask XOR ;
: conditional ( dest cond -- )
#! Compile this after a conditional jump to store f or t
#! in dest depending on the jump being taken or not.
<label> "true" set
<label> "end" set
"true" get swap execute
dup f address MOV
"end" get JMP
"true" get save-xt
t load-indirect
"end" get save-xt ; inline
: fixnum-compare ( vop -- dest )
dup vop-dest v>operand dup rot vop-source v>operand CMP ;
M: %fixnum< generate-node ( vop -- )
fixnum-compare \ JL conditional ;
M: %fixnum<= generate-node ( vop -- )
fixnum-compare \ JLE conditional ;
M: %fixnum> generate-node ( vop -- )
fixnum-compare \ JG conditional ;
M: %fixnum>= generate-node ( vop -- )
fixnum-compare \ JGE conditional ;
M: %eq? generate-node ( vop -- )
fixnum-compare \ JE conditional ;
!
! \ arithmetic-type [
! drop
! EAX [ ESI -4 ] MOV
! EAX BIN: 111 AND
! EDX [ ESI ] MOV
! EDX BIN: 111 AND
! EAX EDX CMP
! 0 JE just-compiled >r
! \ arithmetic-type compile-call
! 0 JMP just-compiled
! compiled-offset r> patch
! EAX 3 SHL
! PUSH-DS
! compiled-offset swap patch
! ] "generator" set-word-prop
!
! \ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-prop

73
library/compiler/x86/generator.factor
View File

@ -1,32 +1,36 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: assembler IN: compiler
USING: alien compiler inference kernel kernel-internals lists USING: alien assembler inference kernel kernel-internals lists
math memory namespaces sequences words ; math memory namespaces sequences words ;
GENERIC: v>operand GENERIC: v>operand
M: integer v>operand ; M: integer v>operand address ;
M: vreg v>operand vreg-n { EAX ECX EDX } nth ; M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
! Not used on x86 ! Not used on x86
M: %prologue generate-node drop ; M: %prologue generate-node drop ;
: compile-call-label ( label -- ) 0 CALL relative ; : compile-c-call ( symbol dll -- )
: compile-jump-label ( label -- ) 0 JMP relative ; 2dup dlsym CALL t rel-dlsym ;
M: %call generate-node ( vop -- )
vop-label dup postpone-word CALL ;
M: %jump-label generate-node ( vop -- )
vop-label JMP ;
M: %call-label generate-node ( vop -- ) M: %call-label generate-node ( vop -- )
vop-label compile-call-label ; vop-label CALL ;
M: %jump generate-node ( vop -- ) M: %jump generate-node ( vop -- )
vop-label dup postpone-word compile-jump-label ; vop-label dup postpone-word JMP ;
M: %jump-f generate-node ( vop -- ) M: %jump-f generate-node ( vop -- )
dup vop-source v>operand f address CMP 0 JNE dup vop-source v>operand f address CMP vop-label JNE ;
vop-label relative ;
M: %jump-t generate-node ( vop -- ) M: %jump-t generate-node ( vop -- )
dup vop-source v>operand f address CMP 0 JE dup vop-source v>operand f address CMP vop-label JE ;
vop-label relative ;
M: %return-to generate-node ( vop -- ) M: %return-to generate-node ( vop -- )
0 PUSH vop-label absolute ; 0 PUSH vop-label absolute ;
@ -35,16 +39,19 @@ M: %return generate-node ( vop -- )
drop RET ; drop RET ;
M: %untag generate-node ( vop -- ) M: %untag generate-node ( vop -- )
vop-source v>operand BIN: 111 bitnot AND ; vop-dest v>operand BIN: 111 bitnot AND ;
M: %tag-fixnum generate-node ( vop -- )
vop-dest v>operand 3 SHL ;
M: %slot generate-node ( vop -- ) M: %slot generate-node ( vop -- )
#! the untagged object is in vop-dest, the tagged slot #! the untagged object is in vop-dest, the tagged slot
#! number is in vop-literal. #! number is in vop-literal.
dup vop-literal v>operand swap vop-dest v>operand dup vop-source v>operand swap vop-dest v>operand
! turn tagged fixnum slot # into an offset, multiple of 4 ! turn tagged fixnum slot # into an offset, multiple of 4
over 1 SHR over 1 SHR
! compute slot address in vop-dest ! compute slot address in vop-dest
dupd ADD tuck ADD
! load slot value in vop-dest ! load slot value in vop-dest
dup unit MOV ; dup unit MOV ;
@ -85,11 +92,12 @@ M: %dispatch generate-node ( vop -- )
compiled-offset r> set-compiled-cell ( fixup -- ) ; compiled-offset r> set-compiled-cell ( fixup -- ) ;
M: %type generate-node ( vop -- ) M: %type generate-node ( vop -- )
#! Intrinstic version of type primitive. #! Intrinstic version of type primitive. It outputs an
#! UNBOXED value in vop-dest.
<label> "object" set <label> "object" set
<label> "f" set <label> "f" set
<label> "end" set <label> "end" set
vop-source v>operand vop-dest v>operand
! Make a copy ! Make a copy
ECX over MOV ECX over MOV
! Get the tag ! Get the tag
@ -97,21 +105,38 @@ M: %type generate-node ( vop -- )
! Compare with object tag number (3). ! Compare with object tag number (3).
dup object-tag CMP dup object-tag CMP
! Jump if the object stores type info in its header ! Jump if the object stores type info in its header
"object" get 0 JE relative "object" get JE
! It doesn't store type info in its header ! It doesn't store type info in its header
dup tag-bits SHL "end" get JMP
"end" get compile-jump-label
"object" get save-xt "object" get save-xt
! It does store type info in its header ! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9). ! Is the pointer itself equal to 3? Then its F_TYPE (9).
ECX object-tag CMP ECX object-tag CMP
"f" get 0 JE relative "f" get JE
! The pointer is not equal to 3. Load the object header. ! The pointer is not equal to 3. Load the object header.
dup ECX object-tag neg 2list MOV dup ECX object-tag neg 2list MOV
! Headers have tag 3. Clear the tag to turn it into a fixnum. dup 3 SHR
dup object-tag XOR "end" get JMP
"end" get compile-jump-label
"f" get save-xt "f" get save-xt
! The pointer is equal to 3. Load F_TYPE (9). ! The pointer is equal to 3. Load F_TYPE (9).
f type tag-bits shift MOV f type MOV
"end" get save-xt ;
M: %arithmetic-type generate-node ( vop -- )
#! This one works directly with the stack. It outputs an
#! UNBOXED value in vop-dest.
EAX check-dest
<label> "end" set
! Load top two stack values
EAX [ ESI -4 ] MOV
ECX [ ESI ] MOV
! Compute their tags
EAX BIN: 111 AND
EDX BIN: 111 AND
! Are the tags equal?
EAX EDX CMP
"end" get JE
! No, they are not equal. Call a runtime function to
! coerce the integers to a higher type.
"arithmetic_type" compile-c-call
"end" get save-xt ; "end" get save-xt ;

13
library/compiler/x86/stack.factor
View File

@ -15,7 +15,7 @@ sequences words ;
: reg-stack ( reg n -- op ) cell * neg 2list ; : reg-stack ( reg n -- op ) cell * neg 2list ;
: ds-op ( n -- op ) ESI swap reg-stack ; : ds-op ( n -- op ) ESI swap reg-stack ;
: rs-op ( n -- op ) ECX swap reg-stack ; : cs-op ( n -- op ) ECX swap reg-stack ;
M: %peek-d generate-node ( vop -- ) M: %peek-d generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal ds-op MOV ; dup vop-dest v>operand swap vop-literal ds-op MOV ;
@ -35,14 +35,15 @@ M: %immediate generate-node ( vop -- )
M: %immediate-d generate-node ( vop -- ) M: %immediate-d generate-node ( vop -- )
vop-literal [ ESI ] swap address MOV ; vop-literal [ ESI ] swap address MOV ;
: load-indirect ( dest literal -- )
intern-literal unit MOV f rel-address ;
M: %indirect generate-node ( vop -- ) M: %indirect generate-node ( vop -- )
#! indirect load of a literal through a table #! indirect load of a literal through a table
dup vop-dest v>operand dup vop-dest v>operand swap vop-literal load-indirect ;
swap vop-literal intern-literal unit MOV
f rel-address ;
M: %peek-r generate-node ( vop -- ) M: %peek-r generate-node ( vop -- )
ECX CS> dup vop-dest v>operand swap vop-literal rs-op MOV ; ECX CS> dup vop-dest v>operand swap vop-literal cs-op MOV ;
M: %dec-r generate-node ( vop -- ) M: %dec-r generate-node ( vop -- )
#! Can only follow a %peek-r #! Can only follow a %peek-r
@ -50,7 +51,7 @@ M: %dec-r generate-node ( vop -- )
M: %replace-r generate-node ( vop -- ) M: %replace-r generate-node ( vop -- )
#! Can only follow a %inc-r #! Can only follow a %inc-r
dup vop-source v>operand swap vop-literal rs-op swap MOV dup vop-source v>operand swap vop-literal cs-op swap MOV
ECX >CS ; ECX >CS ;
M: %inc-r generate-node ( vop -- ) M: %inc-r generate-node ( vop -- )

3
library/inference/inference.factor
View File

@ -79,6 +79,9 @@ M: computed literal-value ( value -- )
"A literal value was expected where a computed value was" "A literal value was expected where a computed value was"
" found: " rot unparse cat3 inference-error ; " found: " rot unparse cat3 inference-error ;
: value-types ( value -- list )
value-class builtin-supertypes ;
: pop-literal ( -- obj ) : pop-literal ( -- obj )
dataflow-drop, pop-d literal-value ; dataflow-drop, pop-d literal-value ;

2
library/inference/types.factor
View File

@ -10,8 +10,6 @@ stdio prettyprint ;
[ tuck builtin-type <class-tie> cons ] project-with [ tuck builtin-type <class-tie> cons ] project-with
[ cdr class-tie-class ] subset ; [ cdr class-tie-class ] subset ;
: value-types ( value -- list ) value-class builtin-supertypes ;
: literal-type ( -- ) : literal-type ( -- )
dataflow-drop, pop-d value-types car dataflow-drop, pop-d value-types car
apply-literal ; apply-literal ;

2
library/math/math.factor
View File

@ -80,3 +80,5 @@ GENERIC: abs ( z -- |z| )
rot [ rot [
rot [ [ rot dup slip -rot ] repeat ] keep -rot rot [ [ rot dup slip -rot ] repeat ] keep -rot
] repeat 2drop ; inline ] repeat 2drop ; inline
: power-of-2? ( n -- ? ) dup dup neg bitand = ;

124
library/test/compiler/intrinsics.factor Normal file
View File

@ -0,0 +1,124 @@
IN: temporary
USING: compiler kernel kernel-internals lists math
math-internals test words ;
! Make sure that intrinsic ops compile to correct code.
: compile-1 ( quot -- word )
gensym [ swap define-compound ] keep dup compile execute ;
[ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
[ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test
[ 3 ] [ 3 1 2 cons [ [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ 3 ] [ 3 1 2 [ cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ 3 ] [ [ 3 1 2 cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ ] [ 1 [ drop ] compile-1 ] unit-test
[ ] [ [ 1 drop ] compile-1 ] unit-test
[ ] [ [ 1 2 2drop ] compile-1 ] unit-test
[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test
[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test
[ 15 ] [ 12 7 [ fixnum-bitor ] compile-1 ] unit-test
[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-1 ] unit-test
[ 15 ] [ [ 12 7 fixnum-bitor ] compile-1 ] unit-test
[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-1 ] unit-test
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test
[ f ] [ 12 7 [ fixnum< ] compile-1 ] unit-test
[ f ] [ 12 [ 7 fixnum< ] compile-1 ] unit-test
[ f ] [ [ 12 7 fixnum< ] compile-1 ] unit-test
[ f ] [ [ 12 12 fixnum< ] compile-1 ] unit-test
[ t ] [ 12 70 [ fixnum< ] compile-1 ] unit-test
[ t ] [ 12 [ 70 fixnum< ] compile-1 ] unit-test
[ t ] [ [ 12 70 fixnum< ] compile-1 ] unit-test
[ f ] [ 12 7 [ fixnum<= ] compile-1 ] unit-test
[ f ] [ 12 [ 7 fixnum<= ] compile-1 ] unit-test
[ f ] [ [ 12 7 fixnum<= ] compile-1 ] unit-test
[ t ] [ [ 12 12 fixnum<= ] compile-1 ] unit-test
[ t ] [ 12 70 [ fixnum<= ] compile-1 ] unit-test
[ t ] [ 12 [ 70 fixnum<= ] compile-1 ] unit-test
[ t ] [ [ 12 70 fixnum<= ] compile-1 ] unit-test
[ t ] [ 12 7 [ fixnum> ] compile-1 ] unit-test
[ t ] [ 12 [ 7 fixnum> ] compile-1 ] unit-test
[ t ] [ [ 12 7 fixnum> ] compile-1 ] unit-test
[ f ] [ [ 12 12 fixnum> ] compile-1 ] unit-test
[ f ] [ 12 70 [ fixnum> ] compile-1 ] unit-test
[ f ] [ 12 [ 70 fixnum> ] compile-1 ] unit-test
[ f ] [ [ 12 70 fixnum> ] compile-1 ] unit-test
[ t ] [ 12 7 [ fixnum>= ] compile-1 ] unit-test
[ t ] [ 12 [ 7 fixnum>= ] compile-1 ] unit-test
[ t ] [ [ 12 7 fixnum>= ] compile-1 ] unit-test
[ t ] [ [ 12 12 fixnum>= ] compile-1 ] unit-test
[ f ] [ 12 70 [ fixnum>= ] compile-1 ] unit-test
[ f ] [ 12 [ 70 fixnum>= ] compile-1 ] unit-test
[ f ] [ [ 12 70 fixnum>= ] compile-1 ] unit-test
[ f ] [ 1 2 [ eq? ] compile-1 ] unit-test
[ f ] [ 1 [ 2 eq? ] compile-1 ] unit-test
[ f ] [ [ 1 2 eq? ] compile-1 ] unit-test
[ t ] [ 3 3 [ eq? ] compile-1 ] unit-test
[ t ] [ 3 [ 3 eq? ] compile-1 ] unit-test
[ t ] [ [ 3 3 eq? ] compile-1 ] unit-test
[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test
[ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test
[ 3 ] [ 13 10 [ fixnum-mod ] compile-1 ] unit-test
[ 3 ] [ 13 [ 10 fixnum-mod ] compile-1 ] unit-test
[ 3 ] [ [ 13 10 fixnum-mod ] compile-1 ] unit-test
[ -3 ] [ -13 10 [ fixnum-mod ] compile-1 ] unit-test
[ -3 ] [ -13 [ 10 fixnum-mod ] compile-1 ] unit-test
[ -3 ] [ [ -13 10 fixnum-mod ] compile-1 ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-1 ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-1 ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-1 ] unit-test
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-1 1 28 fixnum-shift = ] unit-test
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test
[ 6 ] [ 2 3 [ fixnum* ] compile-1 ] unit-test
[ 6 ] [ 2 [ 3 fixnum* ] compile-1 ] unit-test
[ 6 ] [ [ 2 3 fixnum* ] compile-1 ] unit-test
[ -6 ] [ 2 -3 [ fixnum* ] compile-1 ] unit-test
[ -6 ] [ 2 [ -3 fixnum* ] compile-1 ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-1 ] unit-test
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-1 1 40 shift = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-1 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-1 1 40 shift = ] unit-test
[ 2 ] [ 4 2 [ fixnum/i ] compile-1 ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i ] compile-1 ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i ] compile-1 ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test

25
library/test/compiler/stack.factor
View File

@ -6,31 +6,6 @@ USE: lists
USE: math USE: math
USE: kernel USE: kernel
! Make sure that stack ops compile to correct code.
: compile-1 ( quot -- word )
gensym [ swap define-compound ] keep dup compile execute ;
[ ] [ 1 [ drop ] compile-1 ] unit-test
[ ] [ [ 1 drop ] compile-1 ] unit-test
[ ] [ [ 1 2 2drop ] compile-1 ] unit-test
[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test
[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
! Test various kill combinations ! Test various kill combinations
: kill-1 : kill-1

2
library/test/test.factor
View File

@ -89,7 +89,7 @@ SYMBOL: failures
"compiler/simplifier" "compiler/simple" "compiler/simplifier" "compiler/simple"
"compiler/stack" "compiler/ifte" "compiler/stack" "compiler/ifte"
"compiler/generic" "compiler/bail-out" "compiler/generic" "compiler/bail-out"
"compiler/linearizer" "compiler/linearizer" "compiler/intrinsics"
] % ] %
] unless ] unless

48
native/arithmetic.c
View File

@ -1,6 +1,7 @@
#include "factor.h" #include "factor.h"
void primitive_arithmetic_type(void) /* This function is called by the compiler. It returns an untagged fixnum. */
F_FIXNUM arithmetic_type(void)
{ {
CELL obj1 = dpeek(), obj2 = get(ds - CELLS); CELL obj1 = dpeek(), obj2 = get(ds - CELLS);
CELL type1 = TAG(obj1), type2 = TAG(obj2); CELL type1 = TAG(obj1), type2 = TAG(obj2);
@ -17,64 +18,53 @@ void primitive_arithmetic_type(void)
put(ds - CELLS,tag_float(to_float((obj2)))); put(ds - CELLS,tag_float(to_float((obj2))));
break; break;
} }
dpush(tag_fixnum(type1)); return type1;
break;
case BIGNUM_TYPE: case BIGNUM_TYPE:
switch(type1) switch(type1)
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
drepl(tag_bignum(to_bignum(obj1))); drepl(tag_bignum(to_bignum(obj1)));
dpush(tag_fixnum(type2)); return type2;
break;
case FLOAT_TYPE: case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2)))); put(ds - CELLS,tag_float(to_float((obj2))));
dpush(tag_fixnum(type1)); return type1;
break;
default: default:
dpush(tag_fixnum(type1)); return type1;
break;
} }
break;
case RATIO_TYPE: case RATIO_TYPE:
switch(type1) switch(type1)
{ {
case FIXNUM_TYPE: case BIGNUM_TYPE: case FIXNUM_TYPE: case BIGNUM_TYPE:
dpush(tag_fixnum(type2)); return type2;
break;
case FLOAT_TYPE: case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2)))); put(ds - CELLS,tag_float(to_float((obj2))));
dpush(tag_fixnum(type1)); return type1;
break;
default: default:
dpush(tag_fixnum(type1)); return type1;
break;
} }
break;
case FLOAT_TYPE: case FLOAT_TYPE:
switch(type1) switch(type1)
{ {
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE:
drepl(tag_float(to_float(obj1))); drepl(tag_float(to_float(obj1)));
dpush(tag_fixnum(type2)); return type2;
break;
default: default:
dpush(tag_fixnum(type1)); return type1;
break;
} }
break;
case COMPLEX_TYPE: case COMPLEX_TYPE:
switch(type1) switch(type1)
{ {
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE: case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE:
dpush(tag_fixnum(type2)); return type2;
break;
default: default:
dpush(tag_fixnum(type1)); return type1;
break;
} }
break;
default: default:
dpush(tag_fixnum(type2)); return type2;
break;
} }
} }
void primitive_arithmetic_type(void)
{
dpush(arithmetic_type());
}

1
native/arithmetic.h
View File

@ -1 +1,2 @@
F_FIXNUM arithmetic_type(void);
void primitive_arithmetic_type(void); void primitive_arithmetic_type(void);

6
native/s48_bignum.h
View File

@ -65,8 +65,8 @@ s48_bignum_divide(bignum_type numerator, bignum_type denominator,
bignum_type * quotient, bignum_type * remainder); bignum_type * quotient, bignum_type * remainder);
bignum_type s48_bignum_quotient(bignum_type, bignum_type); bignum_type s48_bignum_quotient(bignum_type, bignum_type);
bignum_type s48_bignum_remainder(bignum_type, bignum_type); bignum_type s48_bignum_remainder(bignum_type, bignum_type);
bignum_type s48_long_to_bignum(long); DLLEXPORT bignum_type s48_long_to_bignum(long);
bignum_type s48_long_long_to_bignum(s64 n); DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
bignum_type s48_ulong_to_bignum(unsigned long); bignum_type s48_ulong_to_bignum(unsigned long);
long s48_bignum_to_long(bignum_type); long s48_bignum_to_long(bignum_type);
unsigned long s48_bignum_to_ulong(bignum_type); unsigned long s48_bignum_to_ulong(bignum_type);
@ -86,7 +86,7 @@ long s48_bignum_max_digit_stream_radix(void);
/* Added bitwise operators. */ /* Added bitwise operators. */
bignum_type s48_bignum_bitwise_not(bignum_type), DLLEXPORT bignum_type s48_bignum_bitwise_not(bignum_type),
s48_bignum_arithmetic_shift(bignum_type, long), s48_bignum_arithmetic_shift(bignum_type, long),
s48_bignum_bitwise_and(bignum_type, bignum_type), s48_bignum_bitwise_and(bignum_type, bignum_type),
s48_bignum_bitwise_ior(bignum_type, bignum_type), s48_bignum_bitwise_ior(bignum_type, bignum_type),