commit 041b80986351a07a03ea1b184d551bfe985aae7c
parent f291e20848a797b97ca0771eafe43aba8160193d
Author: Commit-Bot <unknown>
Date: Thu, 29 Jul 2010 17:27:32 +0000
Automatic commit from picoLisp.tgz, From: Thu, 29 Jul 2010 17:27:32 GMT
Diffstat:
5 files changed, 85 insertions(+), 77 deletions(-)
diff --git a/doc64/asm b/doc64/asm
@@ -164,9 +164,9 @@
call adr # Call 'adr'
cc adr(src ..) # C-Call to 'adr' with 'src' arguments
cc adr reg # C-Call to 'adr' with end of stacked args in 'reg'
- darg src src # Pass double argument 'src' and scale 'src'
- dval src # Set up double value 'src'
- fix src # Convert double with scale 'src' to fixnum in 'A' [.sc]
+ darg # Pass double argument in 'A' with scale 'C'
+ dval # Set up double value pointed to by 'C'
+ fix # Convert double with scale 'E' to fixnum in 'E'
ret # Return
begin src # Called from C-function with 'src' arguments
diff --git a/lib/tags b/lib/tags
@@ -32,9 +32,9 @@ and (1643 . "@src64/flow.l")
any (3792 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (597 . "@src64/apply.l")
-arg (2221 . "@src64/main.l")
-args (2197 . "@src64/main.l")
-argv (2842 . "@src64/main.l")
+arg (2198 . "@src64/main.l")
+args (2174 . "@src64/main.l")
+argv (2819 . "@src64/main.l")
as (146 . "@src64/flow.l")
asoq (2942 . "@src64/subr.l")
assoc (2907 . "@src64/subr.l")
@@ -65,7 +65,7 @@ call (3102 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1984 . "@src64/flow.l")
catch (2484 . "@src64/flow.l")
-cd (2597 . "@src64/main.l")
+cd (2574 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -87,7 +87,7 @@ chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1786 . "@src64/subr.l")
close (4180 . "@src64/io.l")
-cmd (2824 . "@src64/main.l")
+cmd (2801 . "@src64/main.l")
cnt (1297 . "@src64/apply.l")
co (2566 . "@src64/flow.l")
commit (1503 . "@src64/db.l")
@@ -98,9 +98,9 @@ connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
ctl (4120 . "@src64/io.l")
-ctty (2622 . "@src64/main.l")
+ctty (2599 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2336 . "@src64/main.l")
+date (2313 . "@src64/main.l")
dbck (2092 . "@src64/db.l")
de (549 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
@@ -110,7 +110,7 @@ del (1852 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
diff (2563 . "@src64/subr.l")
-dir (2755 . "@src64/main.l")
+dir (2732 . "@src64/main.l")
dm (561 . "@src64/flow.l")
do (2158 . "@src64/flow.l")
e (2932 . "@src64/flow.l")
@@ -126,7 +126,7 @@ extern (900 . "@src64/sym.l")
extra (1284 . "@src64/flow.l")
extract (1102 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
-file (2702 . "@src64/main.l")
+file (2679 . "@src64/main.l")
fill (3177 . "@src64/subr.l")
filter (1045 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
@@ -163,7 +163,7 @@ ifn (1884 . "@src64/flow.l")
in (4016 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2611 . "@src64/subr.l")
-info (2659 . "@src64/main.l")
+info (2636 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
@@ -179,15 +179,15 @@ lieu (1163 . "@src64/db.l")
line (3526 . "@src64/io.l")
lines (3679 . "@src64/io.l")
link (1163 . "@src64/subr.l")
-lisp1 (1801 . "@src64/main.l")
-lisp2 (1817 . "@src64/main.l")
-lisp3 (1823 . "@src64/main.l")
-lisp4 (1829 . "@src64/main.l")
-lisp5 (1835 . "@src64/main.l")
-lisp6 (1841 . "@src64/main.l")
-lisp7 (1847 . "@src64/main.l")
-lisp8 (1853 . "@src64/main.l")
-lisp9 (1859 . "@src64/main.l")
+lisp1 (1778 . "@src64/main.l")
+lisp2 (1794 . "@src64/main.l")
+lisp3 (1800 . "@src64/main.l")
+lisp4 (1806 . "@src64/main.l")
+lisp5 (1812 . "@src64/main.l")
+lisp6 (1818 . "@src64/main.l")
+lisp7 (1824 . "@src64/main.l")
+lisp8 (1830 . "@src64/main.l")
+lisp9 (1836 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
@@ -229,7 +229,7 @@ nand (1678 . "@src64/flow.l")
native (1366 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (2204 . "@src64/main.l")
+next (2181 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -243,7 +243,7 @@ onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2945 . "@src64/main.l")
+opt (2922 . "@src64/main.l")
or (1659 . "@src64/flow.l")
out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -276,7 +276,7 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2586 . "@src64/main.l")
+pwd (2563 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
quit (1075 . "@src64/main.l")
quote (141 . "@src64/flow.l")
@@ -287,7 +287,7 @@ raw (465 . "@src64/main.l")
rd (4953 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2250 . "@src64/main.l")
+rest (2227 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -328,7 +328,7 @@ text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
till (3437 . "@src64/io.l")
-time (2469 . "@src64/main.l")
+time (2446 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -341,9 +341,9 @@ up (712 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2574 . "@src64/main.l")
+usec (2551 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2959 . "@src64/main.l")
+version (2936 . "@src64/main.l")
wait (3016 . "@src64/io.l")
when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
diff --git a/src64/arch/x86-64.l b/src64/arch/x86-64.l
@@ -573,36 +573,67 @@
(asm jgt (Adr A)
(_jmp "ja" "jbe") )
-(asm darg (Src S Src2 S2)
- (prinst "movapd" "%xmm4" "%xmm5")
+(asm darg ()
+ (prinst "movapd" "%xmm4" "%xmm5") # Push float stack
(prinst "movapd" "%xmm3" "%xmm4")
(prinst "movapd" "%xmm2" "%xmm3")
(prinst "movapd" "%xmm1" "%xmm2")
(prinst "movapd" "%xmm0" "%xmm1")
- (prinst "cvtsi2sd" (src Src S) "%xmm0")
- (prinst "cvtsi2sd" (src Src2 S2) "%xmm7")
- (prinst "divsd" "%xmm7" "%xmm0") )
-
-(asm dval (Src S)
- (prinst "movsd" (src Src S) "%xmm0") )
-
-(asm fix (Src S)
+ (prinst "testb" "$0x02" "%al") # Short number?
+ (prinst "jz" "2f") # No: Skip
+ (prinst "shr" "$4" "%rdx") # Normalize scale
+ (prinst "shr" "$4" "%rax") # and number
+ (prinst "jnc" "1f") # Carry?
+ (prinst "neg" "%rax") # Yes: Negate
+ (prinl "1:")
+ (prinst "cvtsi2sd" "%rax" "%xmm0") # Convert to fixnum
+ (prinst "cvtsi2sd" "%rdx" "%xmm7")
+ (prinst "divsd" "%xmm7" "%xmm0")
+ (prinst "jmp" "4f")
+ (prinl "2:")
+ (prinst "cmp" "$Nil" "%rax") # NIL?
+ (prinst "mov" "$0x7FF0000000000000" "%rax") # +inf
+ (prinst "jnz" "3f") # No: Skip
+ (prinst "mov" "$0xFFF0000000000000" "%rax") # -inf
+ (prinl "3:")
+ (prinst "push" "%rax") # Push value
+ (prinst "movsd" "(%rsp)" "%xmm0") # into float stack
+ (prinst "add" "$8" "%rsp") # Drop buffer
+ (prinl "4:") )
+
+(asm dval ()
+ (prinst "movsd" "(%rdx)" "%xmm0") )
+
+(asm fix ()
(prinst "sub" "$8" "%rsp") # Space for buffer
(prinst "movsd" "%xmm0" "(%rsp)") # Get value
(prinst "mov" "6(%rsp)" "%ax") # Mantissa [s111 1111 1111 xxxx]
(prinst "and" "$0x7FF0" "%rax") # Infinite/NaN?
(prinst "cmp" "$0x7FF0" "%rax")
(prinst "pop" "%rax") # Keep value
- (prinst "jz" "1f") # Yes: Skip
- (prinst "cvtsi2sd" (src Src S) "%xmm7") # Mulitply with scale
+ (prinst "jz" "2f") # Yes: Skip
+ (prinst "shr" "$4" "%rbx") # Normalize scale
+ (prinst "cvtsi2sd" "%rbx" "%xmm7") # Mulitply with scale
(prinst "mulsd" "%xmm7" "%xmm0")
(prinst "call" "lround")
- (prinst "clc") # No carry: Normal value
- (prinst "jmp" "2f")
+ (prinst "mov" "%rax" "%rbx") # Get into E
+ (prinst "or" "%rax" "%rax") # Negative?
+ (prinst "js" "1f") # Yes: Skip
+ (prinst "shl" "$4" "%rbx") # Make positive short
+ (prinst "orb" "$2" "%bl")
+ (prinst "jmp" "3f")
(prinl "1:")
- (prinst "or" "%rax" "%rax") # Set sign flag
- (prinst "stc") # Carry: Special value
- (prinl "2:") )
+ (prinst "neg" "%rbx") # Negate
+ (prinst "js" "2f") # Still negative: NIL
+ (prinst "shl" "$4" "%rbx") # Make negative short
+ (prinst "orb" "$10" "%bl")
+ (prinst "jmp" "3f")
+ (prinl "2:") # Infinite/NaN
+ (prinst "mov" "$Nil" "%rbx") # Preload NIL
+ (prinst "or" "%rax" "%rax") # Negative?
+ (prinst "js" "3f") # Yes: Skip
+ (prinst "mov" "$TSym" "%rbx") # Load T
+ (prinl "3:") )
(asm cc (Adr A Arg M)
(unless (== 'cc (caar (seek '((L) (== (cadr L) *Statement)) *Program)))
diff --git a/src64/lib/asm.l b/src64/lib/asm.l
@@ -1,4 +1,4 @@
-# 27jul10abu
+# 29jul10abu
# (c) Software Lab. Alexander Burger
# *LittleEndian *Registers optimize
@@ -392,17 +392,17 @@
(cmp4 (source) "*Mode")
(cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode")
(cnt (source) "*Mode")
- (darg (source) "*Mode" (source) "*Mode")
+ (darg)
(dbg)
(dec (destination) "*Mode")
(div (source) "*Mode")
(drop)
- (dval (source) "*Mode")
+ (dval)
(eval)
(eval+)
(eval/ret)
(exec (reg (read)))
- (fix (source) "*Mode")
+ (fix)
(hx2 (read))
(inc (destination) "*Mode")
(initCode)
diff --git a/src64/main.l b/src64/main.l
@@ -1495,13 +1495,8 @@
ld C (E CDR) # Double?
cnt C
if nz # Yes
- shr C 4 # Normalize scale
- ld A (E) # and number
- shr A 4
- if c # Sign?
- neg A # Yes
- end
- darg A C # Pass double argument
+ ld A (E) # Get number
+ darg # Pass double argument
else
ld E C # Ignore variable
ld C ((E)) # Get buffer size
@@ -1592,30 +1587,12 @@
if ne
cnt E # Scale?
if nz # Yes
- shr E 4 # Normalize
null C # Pointer?
if nz # Yes
- dval (C) # Get double value
+ dval # Get double value
add C 8 # Size of double
end
- fix E # Get fixpoint number
- if nc
- ld E A # Normal value
- null E # Negative?
- if ns # No
- shl E 4 # Make short number
- or E CNT
- else
- neg E # Negate
- shl E 4 # Make negative short number
- or E (| SIGN CNT)
- end
- else
- ld E Nil # Special value
- if ns # Infinite?
- ld E TSym
- end
- end
+ fix # Get fixpoint number or flg
else
cmp E ISym # 'I'?
if eq # Yes
