diff --git a/doc/handbook.tex b/doc/handbook.tex index a9ccf83189..18a152db1c 100644 --- a/doc/handbook.tex +++ b/doc/handbook.tex @@ -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 )} diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 4bdb69d04a..253687495b 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -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 diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 65a8f351d9..26723ea22e 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -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 diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index a8574307e2..bb9efe1ff0 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -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" diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 6786f8ee90..a6556611cb 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -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 ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 4d3063124c..684a08da31 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -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 0 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 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 1 %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 diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 2b0cb07f92..eea6f48ce3 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -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 diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index 41f282efbf..47cf2c4c83 100644 --- a/library/compiler/vops.factor +++ b/library/compiler/vops.factor @@ -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 src-vop <%untag> ; +: %untag dest-vop <%untag> ; VOP: %slot -: %slot ( vreg n ) >r >r f r> r> f <%slot> ; +: %slot ( n vreg ) >r r> 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 r> r> f <%fast-set-slot> ; -! some slightly optimized inline assembly -VOP: %type -: %type ( 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 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 ) dest-vop <%type> ; + +VOP: %arithmetic-type +: %arithmetic-type empty-vop <%arithmetic-type> ; + +VOP: %tag-fixnum +: %tag-fixnum dest-vop <%tag-fixnum> ; + +: check-dest ( vop reg -- ) + swap vop-dest v>operand = [ + "invalid VOP destination" throw + ] unless ; diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor index e980151e5e..931bf7972c 100644 --- a/library/compiler/x86/alien.factor +++ b/library/compiler/x86/alien.factor @@ -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 [ diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index 81fd80535c..ac909daed2 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -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 ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index abd8f3ecdd..b9ab04e61b 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -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? +