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{
\vocabulary{kernel}
\ordinaryword{drop}{drop ( x -- )}
\ordinaryword{2drop}{drop ( x y -- )}
\ordinaryword{3drop}{drop ( x y z -- )}
\ordinaryword{2drop}{2drop ( x y -- )}
\ordinaryword{3drop}{3drop ( x y z -- )}
\ordinaryword{nip}{nip ( x y -- y )}
\ordinaryword{2nip}{2nip ( x y -- y )}
\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/interpreter.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
"delegate" [ "generic" ] search

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

@ -24,19 +24,42 @@ recrossref
drop
] ifte ;
! These are loaded here until bootstrap gets some fixes
"Loading compiler and friends..." print
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/malloc.factor"
"/library/io/buffer.factor"
] pull-in
"Loading compiler backend..." print
cpu "x86" = [
"/library/compiler/x86/assembler.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/generator.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/fixnum.factor"
"/library/compiler/x86/alien.factor"
] pull-in
@ -48,38 +71,4 @@ cpu "ppc" = [
"/library/compiler/ppc/alien.factor"
] 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

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

@ -3,7 +3,41 @@
USING: alien assembler command-line compiler io-internals kernel
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 [
"/library/math/constants.factor"

11
library/compiler/generator.factor
View File

@ -1,10 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
DEFER: compile-call-label ( label -- )
DEFER: compile-jump-label ( label -- )
IN: compiler
USING: assembler errors inference kernel lists math namespaces
sequences strings vectors words ;
@ -52,12 +47,6 @@ M: %label generate-node ( vop -- )
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 ;
M: %target-label generate-node vop-label compile-target ;

88
library/compiler/intrinsics.factor
View File

@ -35,8 +35,8 @@ words ;
\ swap [
drop
in-2
1 0 %replace-d ,
0 1 %replace-d ,
0 0 %replace-d ,
1 1 %replace-d ,
] "linearizer" set-word-prop
\ over [
@ -97,7 +97,7 @@ words ;
drop
in-2
1 %dec-d ,
1 %untag ,
0 %untag ,
1 0 %slot ,
] ifte out-1
] "linearizer" set-word-prop
@ -110,13 +110,13 @@ words ;
1 %dec-d ,
in-2
2 %dec-d ,
slot@ >r 1 0 r> %fast-set-slot ,
slot@ >r 0 1 r> %fast-set-slot ,
] [
drop
in-3
3 %dec-d ,
1 %untag ,
2 1 0 %set-slot ,
0 1 2 %set-slot ,
] ifte
] "linearizer" set-word-prop
@ -126,43 +126,93 @@ words ;
drop
in-1
0 %type ,
0 %tag-fixnum ,
out-1
] "linearizer" set-word-prop
: binary-op-reg ( op -- )
in-2
<< vreg f 1 >> << vreg f 0 >> rot execute ,
\ arithmetic-type intrinsic
\ 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 ,
out-1 ;
r> 0 %replace-d , ;
: binary-op ( node op -- )
node-consume-d rot hash
: binary-op ( node op out -- )
#! out is a vreg where the vop stores the result.
>r >r node-consume-d swap hash
dup top-literal? [
1 %dec-d ,
in-1
peek literal-value << vreg f 0 >> rot execute ,
out-1
peek literal-value 0 <vreg> r> execute ,
r> 0 %replace-d ,
] [
drop
binary-op-reg
r> r> binary-op-reg
] ifte ;
[
[[ fixnum+ %fixnum+ ]]
[[ fixnum- %fixnum- ]]
[[ fixnum* %fixnum* ]]
[[ fixnum-mod %fixnum-mod ]]
[[ fixnum-bitand %fixnum-bitand ]]
[[ fixnum-bitor %fixnum-bitor ]]
[[ fixnum-bitxor %fixnum-bitxor ]]
[[ fixnum/i %fixnum/i ]]
[[ fixnum-shift %fixnum-shift ]]
[[ fixnum<= %fixnum<= ]]
[[ fixnum< %fixnum< ]]
[[ fixnum>= %fixnum>= ]]
[[ fixnum> %fixnum> ]]
] [
uncons over intrinsic
[ literal, \ binary-op , ] make-list
[ literal, 0 , \ binary-op , ] make-list
"linearizer" set-word-prop
] 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
strings words ;
: simplify ;
! The linear IR being simplified is stored in this variable.
SYMBOL: simplifying
: simplifiers ( linear -- list )
#! A list of quotations with stack effect
#! ( linear -- linear ? ) that can simplify the first node
#! in the linear IR.
car car "simplifiers" word-prop ;
: simplify-node ( linear list -- linear ? )
dup [
uncons >r call [
r> drop t
] [
r> simplify-node
] ifte
] when ;
: simplify-1 ( linear -- linear ? )
#! Return a new linear IR.
dup [
dup simplifiers simplify-node
[ uncons simplify-1 drop cons t ]
[ uncons simplify-1 >r cons r> ] ifte
] [
f
] ifte ;
: simplify ( linear -- linear )
#! Keep simplifying until simplify-1 returns f.
[
dup simplifying set simplify-1
] with-scope [ simplify ] when ;
: label-called? ( label linear -- ? )
[ uncons pick = swap #label = not and ] some? nip ;
#label [
[
dup car cdr simplifying get label-called?
[ f ] [ cdr t ] ifte
]
] "simplifiers" set-word-prop
: next-physical? ( op linear -- ? )
cdr dup [ car car = ] [ 2drop f ] ifte ;
: cancel ( linear op -- linear param ? )
#! If the following op is as given, remove it, and return
#! its param.
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
\ drop [
[
#push-immediate cancel [
#replace-immediate swons swons t
] when
] [
#push-indirect cancel [
#replace-indirect swons swons t
] when
]
] "simplifiers" set-word-prop
: find-label ( label -- rest )
simplifying get [
uncons pick = swap #label = and
] some? nip ;
: next-logical ( linear -- linear )
dup car car "next-logical" word-prop call ;
#label [
cdr next-logical
] "next-logical" set-word-prop
#jump-label [
car cdr find-label cdr
] "next-logical" set-word-prop
#target-label [
car cdr find-label cdr
] "next-logical" set-word-prop
: next-logical? ( op linear -- ? )
next-logical dup [ car car = ] [ 2drop f ] ifte ;
: reduce ( linear op new -- linear ? )
>r over cdr next-logical? [
unswons cdr r> swons swons t
] [
r> drop f
] ifte ;
#call [
[ #return #jump reduce ]
] "simplifiers" set-word-prop
#call-label [
[ #return #jump-label reduce ]
] "simplifiers" set-word-prop
: double-jump ( linear op1 op2 -- linear ? )
#! 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
#! list with a jump of type op2.
swap pick next-logical? [
over next-logical car cdr cons swap cdr cons t
] [
drop f
] ifte ;
: useless-jump ( linear -- linear ? )
#! A jump to a label immediately following is not needed.
dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
: (dead-code) ( linear -- linear ? )
#! Remove all nodes until the next #label.
dup [
dup car car #label = [
f
] [
cdr (dead-code) t or
] ifte
] [
f
] ifte ;
: dead-code ( linear -- linear ? )
uncons (dead-code) >r cons r> ;
#jump-label [
[ #return #return double-jump ]
[ #jump-label #jump-label double-jump ]
[ #jump #jump double-jump ]
[ useless-jump ]
[ dead-code ]
] "simplifiers" set-word-prop
#target-label [
[ #jump-label #target-label double-jump ]
! [ #jump #target double-jump ]
] "simplifiers" set-word-prop
#jump [ [ dead-code ] ] "simplifiers" set-word-prop
#return [ [ dead-code ] ] "simplifiers" set-word-prop
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop
! SYMBOL: simplifying
!
! : simplifiers ( linear -- list )
! #! A list of quotations with stack effect
! #! ( linear -- linear ? ) that can simplify the first node
! #! in the linear IR.
! car car "simplifiers" word-prop ;
!
! : simplify-node ( linear list -- linear ? )
! dup [
! uncons >r call [
! r> drop t
! ] [
! r> simplify-node
! ] ifte
! ] when ;
!
! : simplify-1 ( linear -- linear ? )
! #! Return a new linear IR.
! dup [
! dup simplifiers simplify-node
! [ uncons simplify-1 drop cons t ]
! [ uncons simplify-1 >r cons r> ] ifte
! ] [
! f
! ] ifte ;
!
! : simplify ( linear -- linear )
! #! Keep simplifying until simplify-1 returns f.
! [
! dup simplifying set simplify-1
! ] with-scope [ simplify ] when ;
!
! : label-called? ( label linear -- ? )
! [ uncons pick = swap #label = not and ] some? nip ;
!
! #label [
! [
! dup car cdr simplifying get label-called?
! [ f ] [ cdr t ] ifte
! ]
! ] "simplifiers" set-word-prop
!
! : next-physical? ( op linear -- ? )
! cdr dup [ car car = ] [ 2drop f ] ifte ;
!
! : cancel ( linear op -- linear param ? )
! #! If the following op is as given, remove it, and return
! #! its param.
! over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
!
! \ drop [
! [
! #push-immediate cancel [
! #replace-immediate swons swons t
! ] when
! ] [
! #push-indirect cancel [
! #replace-indirect swons swons t
! ] when
! ]
! ] "simplifiers" set-word-prop
!
! : find-label ( label -- rest )
! simplifying get [
! uncons pick = swap #label = and
! ] some? nip ;
!
! : next-logical ( linear -- linear )
! dup car car "next-logical" word-prop call ;
!
! #label [
! cdr next-logical
! ] "next-logical" set-word-prop
!
! #jump-label [
! car cdr find-label cdr
! ] "next-logical" set-word-prop
!
! #target-label [
! car cdr find-label cdr
! ] "next-logical" set-word-prop
!
! : next-logical? ( op linear -- ? )
! next-logical dup [ car car = ] [ 2drop f ] ifte ;
!
! : reduce ( linear op new -- linear ? )
! >r over cdr next-logical? [
! unswons cdr r> swons swons t
! ] [
! r> drop f
! ] ifte ;
!
! #call [
! [ #return #jump reduce ]
! ] "simplifiers" set-word-prop
!
! #call-label [
! [ #return #jump-label reduce ]
! ] "simplifiers" set-word-prop
!
! : double-jump ( linear op1 op2 -- linear ? )
! #! 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
! #! list with a jump of type op2.
! swap pick next-logical? [
! over next-logical car cdr cons swap cdr cons t
! ] [
! drop f
! ] ifte ;
!
! : useless-jump ( linear -- linear ? )
! #! A jump to a label immediately following is not needed.
! dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
!
! : (dead-code) ( linear -- linear ? )
! #! Remove all nodes until the next #label.
! dup [
! dup car car #label = [
! f
! ] [
! cdr (dead-code) t or
! ] ifte
! ] [
! f
! ] ifte ;
!
! : dead-code ( linear -- linear ? )
! uncons (dead-code) >r cons r> ;
!
! #jump-label [
! [ #return #return double-jump ]
! [ #jump-label #jump-label double-jump ]
! [ #jump #jump double-jump ]
! [ useless-jump ]
! [ dead-code ]
! ] "simplifiers" set-word-prop
!
! #target-label [
! [ #jump-label #target-label double-jump ]
! ! [ #jump #target double-jump ]
! ] "simplifiers" set-word-prop
!
! #jump [ [ dead-code ] ] "simplifiers" set-word-prop
! #return [ [ 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: generic kernel namespaces parser ;
USING: errors generic kernel namespaces parser ;
! The linear IR is the second of the two intermediate
! 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/src-vop ( label src) swap >r f f r> ;
: src-vop ( src) f f f ;
: dest-vop ( dest) f swap f f ;
: src/dest-vop ( src dest) f f ;
! miscellanea
@ -84,10 +85,9 @@ VOP: %inc-r
: %inc-r ( n -- ) >r f f r> f <%inc-r> ;
: in-1 0 0 %peek-d , ;
: in-2 in-1 1 1 %peek-d , ;
: in-3 in-2 2 2 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
: out-1 0 0 %replace-d , ;
: out-2 out-1 1 1 %replace-d , ;
! indirect load of a literal through a table
VOP: %indirect
@ -95,9 +95,9 @@ VOP: %indirect
! object slot accessors
VOP: %untag
: %untag <vreg> src-vop <%untag> ;
: %untag <vreg> dest-vop <%untag> ;
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
: %set-slot ( vreg:value vreg:obj n )
@ -111,20 +111,36 @@ VOP: %fast-set-slot
: %fast-set-slot ( vreg:value vreg:obj n )
>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
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/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-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
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: %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 ;
\ alien-invoke [
uncons load-library 2dup dlsym CALL t rel-dlsym
uncons load-library compile-c-call
] "generator" set-word-prop
\ alien-global [

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

@ -1,30 +1,5 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2005 Slava Pestov.
!
! 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.
! See http://factor.sf.net/license.txt for BSD license.
USE: compiler
IN: assembler
USE: words
@ -210,30 +185,35 @@ M: operand MOV HEX: 89 2-operand ;
GENERIC: JMP ( op -- )
M: integer JMP HEX: e9 compile-byte from compile-cell ;
M: operand JMP HEX: ff compile-byte BIN: 100 1-operand ;
M: word JMP 0 JMP relative ;
GENERIC: CALL ( op -- )
M: integer CALL HEX: e8 compile-byte from compile-cell ;
M: operand CALL HEX: ff compile-byte BIN: 010 1-operand ;
M: word CALL 0 CALL relative ;
: JUMPcc ( addr opcode -- )
HEX: 0f compile-byte compile-byte from compile-cell ;
GENERIC: JUMPcc ( opcode addr -- )
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 ;
: JNO HEX: 81 JUMPcc ;
: JB HEX: 82 JUMPcc ;
: JAE HEX: 83 JUMPcc ;
: JE HEX: 84 JUMPcc ;
: JNE HEX: 85 JUMPcc ;
: JBE HEX: 86 JUMPcc ;
: JA HEX: 87 JUMPcc ;
: JS HEX: 88 JUMPcc ;
: JNS HEX: 89 JUMPcc ;
: JP HEX: 8a JUMPcc ;
: JNP HEX: 8b JUMPcc ;
: JL HEX: 8c JUMPcc ;
: JGE HEX: 8d JUMPcc ;
: JLE HEX: 8e JUMPcc ;
: JG HEX: 8f JUMPcc ;
: JO HEX: 80 swap JUMPcc ;
: JNO HEX: 81 swap JUMPcc ;
: JB HEX: 82 swap JUMPcc ;
: JAE HEX: 83 swap JUMPcc ;
: JE HEX: 84 swap JUMPcc ;
: JNE HEX: 85 swap JUMPcc ;
: JBE HEX: 86 swap JUMPcc ;
: JA HEX: 87 swap JUMPcc ;
: JS HEX: 88 swap JUMPcc ;
: JNS HEX: 89 swap JUMPcc ;
: JP HEX: 8a swap JUMPcc ;
: JNP HEX: 8b swap JUMPcc ;
: JL HEX: 8c swap JUMPcc ;
: JGE HEX: 8d swap JUMPcc ;
: JLE HEX: 8e swap JUMPcc ;
: JG HEX: 8f swap JUMPcc ;
: RET ( -- ) HEX: c3 compile-byte ;
@ -271,21 +251,20 @@ GENERIC: CMP ( dst src -- )
M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ;
M: operand CMP OCT: 071 2-operand ;
: IMUL ( dst src -- )
HEX: 0f compile-byte HEX: af 2-operand ;
: IDIV ( src -- )
#! IDIV is weird on x86. Only the divisor is given as an
#! explicit operand. The quotient is stored in EAX, the
#! remainder in EDX.
HEX: f7 compile-byte BIN: 111 1-operand ;
: NOT ( dst -- ) HEX: f7 compile-byte BIN: 010 1-operand ;
: NEG ( dst -- ) HEX: f7 compile-byte BIN: 011 1-operand ;
: MUL ( dst -- ) HEX: f7 compile-byte BIN: 100 1-operand ;
: IMUL ( src -- ) HEX: f7 compile-byte BIN: 101 1-operand ;
: DIV ( dst -- ) HEX: f7 compile-byte BIN: 110 1-operand ;
: IDIV ( src -- ) HEX: f7 compile-byte BIN: 111 1-operand ;
: CDQ HEX: 99 compile-byte ;
: SHL ( dst src -- ) HEX: c1 BIN: 100 immediate-8 ;
: SHR ( dst src -- ) HEX: c1 BIN: 101 immediate-8 ;
: SHL ( dst n -- ) HEX: c1 BIN: 100 immediate-8 ;
: SHR ( dst n -- ) 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 -- )
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.
!
! 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USE: assembler
USE: inference
USE: math
USE: words
USE: kernel
USE: alien
USE: lists
USE: math-internals
USING: assembler errors kernel math math-internals memory
namespaces words ;
! This file provides compiling definitions for fixnum words
! that are faster than what C gives us. There is a lot of
! 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.
: dest/src ( vop -- dest src )
dup vop-dest v>operand swap vop-source v>operand ;
: fixnum-insn ( overflow opcode -- )
#! This needs to be factored.
EAX [ ESI -4 ] MOV
EAX [ ESI ] rot execute
0 JNO just-compiled
swap compile-call
0 JMP just-compiled >r
compiled-offset swap patch
ESI 4 SUB
[ ESI ] EAX MOV
r> compiled-offset swap patch ;
: simple-overflow ( dest -- )
#! If the previous arithmetic operation overflowed, then we
#! turn the result into a bignum and leave it in EAX. This
#! does not trigger a GC if memory is full -- is that bad?
<label> "end" set
"end" get JNO
! There was an overflow. Untag the fixnum and add the carry.
! Thanks to Dazhbog for figuring out this trick.
dup RCR
dup 2 SAR
! 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+ [
drop \ fixnum+ \ ADD fixnum-insn
] "generator" set-word-prop
M: %fixnum+ generate-node ( vop -- )
dest/src dupd ADD simple-overflow ;
\ fixnum+ [ \ fixnum+ self ] "infer" set-word-prop
M: %fixnum- generate-node ( vop -- )
dest/src dupd SUB simple-overflow ;
\ fixnum- [
drop \ fixnum- \ SUB fixnum-insn
] "generator" set-word-prop
\ fixnum- [ \ fixnum- self ] "infer" set-word-prop
\ fixnum* [
M: %fixnum* generate-node ( vop -- )
drop
EAX [ ESI -4 ] MOV
EAX 3 SHR
EAX [ ESI ] IMUL
0 JNO just-compiled
\ fixnum* 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
! both inputs are tagged, so one of them needs to have its
! tag removed.
EAX tag-bits SAR
ECX IMUL
<label> "end" set
"end" get JNO
! make a bignum
EDX PUSH
EAX PUSH
"s48_long_long_to_bignum" f compile-c-call
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
\ fixnum/i [
M: %fixnum-mod generate-node ( vop -- )
#! This has specific register requirements. Inputs are in
#! EAX and ECX, and the result is in EDX.
drop
EAX [ ESI -4 ] MOV
CDQ
[ ESI ] 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
ECX IDIV ;
\ fixnum/i [ \ fixnum/i self ] "infer" set-word-prop
\ fixnum-mod [
: generate-fixnum/mod
#! The same code is used for %fixnum/i and %fixnum/mod.
#! This has specific register requirements. Inputs are in
#! EAX and ECX, and the result is in EDX.
<label> "end" set
drop
EAX [ ESI -4 ] MOV
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
0 JNO just-compiled
\ fixnum/i compile-call
0 JMP just-compiled >r
compiled-offset swap patch
ESI 4 SUB
[ ESI ] EDX MOV
r> compiled-offset swap patch
] "generator" set-word-prop
! Did it overflow?
"end" get JNO
! There was an overflow, so make ECX into a bignum. we must
! save EDX since its volatile.
EDX PUSH
ECX 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
! 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 [
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
M: %fixnum/mod generate-node generate-fixnum/mod ;
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop
M: %fixnum-bitand generate-node ( vop -- ) dest/src AND ;
: PUSH-DS ( -- )
#! Push EAX to datastack.
ESI 4 ADD
[ ESI ] EAX MOV ;
M: %fixnum-bitor generate-node ( vop -- ) dest/src OR ;
\ 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
M: %fixnum-bitxor generate-node ( vop -- ) dest/src XOR ;
\ 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
USING: alien compiler inference kernel kernel-internals lists
IN: compiler
USING: alien assembler inference kernel kernel-internals lists
math memory namespaces sequences words ;
GENERIC: v>operand
M: integer v>operand ;
M: integer v>operand address ;
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
! Not used on x86
M: %prologue generate-node drop ;
: compile-call-label ( label -- ) 0 CALL relative ;
: compile-jump-label ( label -- ) 0 JMP relative ;
: compile-c-call ( symbol dll -- )
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 -- )
vop-label compile-call-label ;
vop-label CALL ;
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 -- )
dup vop-source v>operand f address CMP 0 JNE
vop-label relative ;
dup vop-source v>operand f address CMP vop-label JNE ;
M: %jump-t generate-node ( vop -- )
dup vop-source v>operand f address CMP 0 JE
vop-label relative ;
dup vop-source v>operand f address CMP vop-label JE ;
M: %return-to generate-node ( vop -- )
0 PUSH vop-label absolute ;
@ -35,16 +39,19 @@ M: %return generate-node ( vop -- )
drop RET ;
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 -- )
#! the untagged object is in vop-dest, the tagged slot
#! 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
over 1 SHR
! compute slot address in vop-dest
dupd ADD
tuck ADD
! load slot value in vop-dest
dup unit MOV ;
@ -85,11 +92,12 @@ M: %dispatch generate-node ( vop -- )
compiled-offset r> set-compiled-cell ( fixup -- ) ;
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> "f" set
<label> "end" set
vop-source v>operand
vop-dest v>operand
! Make a copy
ECX over MOV
! Get the tag
@ -97,21 +105,38 @@ M: %type generate-node ( vop -- )
! Compare with object tag number (3).
dup object-tag CMP
! 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
dup tag-bits SHL
"end" get compile-jump-label
"end" get JMP
"object" get save-xt
! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9).
ECX object-tag CMP
"f" get 0 JE relative
"f" get JE
! The pointer is not equal to 3. Load the object header.
dup ECX object-tag neg 2list MOV
! Headers have tag 3. Clear the tag to turn it into a fixnum.
dup object-tag XOR
"end" get compile-jump-label
dup 3 SHR
"end" get JMP
"f" get save-xt
! 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 ;

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

@ -15,7 +15,7 @@ sequences words ;
: reg-stack ( reg n -- op ) cell * neg 2list ;
: 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 -- )
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 -- )
vop-literal [ ESI ] swap address MOV ;
: load-indirect ( dest literal -- )
intern-literal unit MOV f rel-address ;
M: %indirect generate-node ( vop -- )
#! indirect load of a literal through a table
dup vop-dest v>operand
swap vop-literal intern-literal unit MOV
f rel-address ;
dup vop-dest v>operand swap vop-literal load-indirect ;
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 -- )
#! Can only follow a %peek-r
@ -50,7 +51,7 @@ M: %dec-r generate-node ( vop -- )
M: %replace-r generate-node ( vop -- )
#! 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 ;
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"
" found: " rot unparse cat3 inference-error ;
: value-types ( value -- list )
value-class builtin-supertypes ;
: pop-literal ( -- obj )
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
[ cdr class-tie-class ] subset ;
: value-types ( value -- list ) value-class builtin-supertypes ;
: literal-type ( -- )
dataflow-drop, pop-d value-types car
apply-literal ;

2
library/math/math.factor
View File

@ -80,3 +80,5 @@ GENERIC: abs ( z -- |z| )
rot [
rot [ [ rot dup slip -rot ] repeat ] keep -rot
] 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: 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
: kill-1

2
library/test/test.factor
View File

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

48
native/arithmetic.c
View File

@ -1,6 +1,7 @@
#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 type1 = TAG(obj1), type2 = TAG(obj2);
@ -17,64 +18,53 @@ void primitive_arithmetic_type(void)
put(ds - CELLS,tag_float(to_float((obj2))));
break;
}
dpush(tag_fixnum(type1));
break;
return type1;
case BIGNUM_TYPE:
switch(type1)
{
case FIXNUM_TYPE:
drepl(tag_bignum(to_bignum(obj1)));
dpush(tag_fixnum(type2));
break;
return type2;
case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2))));
dpush(tag_fixnum(type1));
break;
return type1;
default:
dpush(tag_fixnum(type1));
break;
return type1;
}
break;
case RATIO_TYPE:
switch(type1)
{
case FIXNUM_TYPE: case BIGNUM_TYPE:
dpush(tag_fixnum(type2));
break;
return type2;
case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2))));
dpush(tag_fixnum(type1));
break;
return type1;
default:
dpush(tag_fixnum(type1));
break;
return type1;
}
break;
case FLOAT_TYPE:
switch(type1)
{
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE:
drepl(tag_float(to_float(obj1)));
dpush(tag_fixnum(type2));
break;
return type2;
default:
dpush(tag_fixnum(type1));
break;
return type1;
}
break;
case COMPLEX_TYPE:
switch(type1)
{
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE:
dpush(tag_fixnum(type2));
break;
return type2;
default:
dpush(tag_fixnum(type1));
break;
return type1;
}
break;
default:
dpush(tag_fixnum(type2));
break;
return type2;
}
}
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);

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 s48_bignum_quotient(bignum_type, bignum_type);
bignum_type s48_bignum_remainder(bignum_type, bignum_type);
bignum_type s48_long_to_bignum(long);
bignum_type s48_long_long_to_bignum(s64 n);
DLLEXPORT bignum_type s48_long_to_bignum(long);
DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
bignum_type s48_ulong_to_bignum(unsigned long);
long s48_bignum_to_long(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. */
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_bitwise_and(bignum_type, bignum_type),
s48_bignum_bitwise_ior(bignum_type, bignum_type),