FEAT: first release of preliminary support for floating points (IA-32…

… only). New datatypes: float32! and float64! (float! can be used as an alias for float64!) Only float64! is currently implemented. You can assign literals using decimal or scientific notation to variables and pass them to external functions only (for now). Variadic/typed functions cannot be used on floats for now. Example of what can be achieved so far: Red/System [ ] #import [ LIBC-file cdecl [ cos: "cos" [ x [float!] return: [float!] ] ] ] pi: 3.14159265358979 printf ["%.14f" cos pi]
red · Jan 8, 2012 · bea1aa7 · bea1aa7
1 parent 6f25686
commit bea1aa7
Show file tree

Hide file tree

Showing 7 changed files with 195 additions and 9 deletions.
diff --git a/red-system/compiler.r b/red-system/compiler.r
@@ -8,6 +8,7 @@ REBOL [
 
 do %utils/r2-forward.r
 do %utils/int-to-bin.r
+do %utils/IEEE-754.r
 do %utils/virtual-struct.r
 do %utils/secure-clean-path.r
 do %linker.r
@@ -52,6 +53,7 @@ system-dialect: context [
 
 		not-set!:	  [logic! integer!]								  ;-- reserved for internal use only
 		number!: 	  [byte! integer!]								  ;-- reserved for internal use only
+		any-float!:	  [float! float32! float64!]						;-- reserved for internal use only
 		pointers!:	  [pointer! struct! c-string!] 					  ;-- reserved for internal use only
 		any-pointer!: union pointers! [function!]		  			  ;-- reserved for internal use only
 		poly!:		  union number!	pointers!					  	  ;-- reserved for internal use only
@@ -100,6 +102,7 @@ system-dialect: context [
 
 		type-syntax: [
 			'logic! | 'int32! | 'integer! | 'uint8! | 'byte! | 'int16!
+			| 'float! | 'float32! | 'float64!
 			| 'c-string!
 			| 'pointer! into [pointer-syntax]
 			| 'struct!  into [struct-syntax]
@@ -321,6 +324,10 @@ system-dialect: context [
 			count
 		]
 
+		any-float?: func [type [block!]][
+			find any-float! type/1
+		]
+
 		any-pointer?: func [type [block!]][
 			type: first resolve-aliased type
 
@@ -444,6 +451,7 @@ system-dialect: context [
 				word! 	 [resolve-type value]
 				char!	 [[byte!]]
 				integer! [[integer!]]
+				decimal! [[float!]]
 				string!	 [[c-string!]]
 				path!	 [resolve-path-type value]
 				object!  [value/type]
@@ -1505,6 +1513,9 @@ system-dialect: context [
 			if import? [emitter/target/emit-stack-align-prolog length? args]
 
 			type: functions/:name/2
+?? name
+?? type
+?? args
 			either type <> 'op [					
 				forall list [							;-- push function's arguments on stack
 					if block? unbox list/1 [comp-expression list/1 yes]	;-- nested call
@@ -1704,6 +1715,7 @@ system-dialect: context [
 				char!		[do pass]
 				integer!	[do pass]
 				string!		[do pass]
+				decimal!	[do pass]
 			][
 				throw-error [
 					pick [

diff --git a/red-system/emitter.r b/red-system/emitter.r
@@ -35,6 +35,9 @@ emitter: context [
 		;uint16!	2	unsigned
 		;uint32!	4	unsigned
 		;uint64!	8	unsigned
+		float32!	4	signed
+		float64!	8	signed
+		float!		8	signed
 		logic!		4	-
 		pointer!	4	-				;-- 32-bit, 8 for 64-bit
 		c-string!	4	-				;-- 32-bit, 8 for 64-bit
@@ -50,6 +53,9 @@ emitter: context [
 		byte-ptr!   5
 		int-ptr!	6
 		function!	7
+		float!		8
+		float32!	9
+		float64!	10
 		struct!		1000
 	]
 
@@ -206,6 +212,11 @@ emitter: context [
 				]
 				append ptr value
 			]
+			float! float64! [
+				pad-data-buf 8							;-- align 64-bit floats on 64-bit
+				ptr: tail data-buf	
+				append ptr IEEE-754/to-binary64/rev value
+			]
 			c-string! [
 				either string? value [
 					repend ptr [value null]

diff --git a/red-system/runtime/common.reds b/red-system/runtime/common.reds
@@ -23,6 +23,8 @@ Red/System [
 #define as-byte		  [as byte!]
 #define as-logic	  [as logic!]
 #define as-integer	  [as integer!]
+#define as-float	  [as float!]
+#define as-float32	  [as float32!]
 #define as-c-string	  [as c-string!]
 
 #define null-byte	  #"^(00)"
@@ -42,6 +44,9 @@ Red/System [
 #define type-byte-ptr!  5
 #define type-int-ptr!	6
 #define type-function!	7
+#define type-float!		8
+#define type-float32!	9
+#define type-float64!	10
 #define type-struct!	1000
 #define any-struct?		[1000 <=]
 #define alias?  		[1001 <=]

diff --git a/red-system/runtime/lib-C.reds b/red-system/runtime/lib-C.reds
@@ -61,4 +61,14 @@ prin-int: func [i [integer!] return: [integer!]][
 prin-hex: func [i [integer!] return: [integer!]][
 	printf ["%08X" i]
 	i
+]
+
+prin-float: func [f [float!] return: [float!]][
+	printf ["%f" f]
+	f
+]
+
+prin-float32: func [f [float32!] return: [float32!]][
+	printf ["%f" f]
+	f
 ]
diff --git a/red-system/runtime/utils.reds b/red-system/runtime/utils.reds
@@ -47,15 +47,21 @@ _print: func [
 		if list/type = type-integer! [
 			prin-int list/value
 		]
+		if list/type = type-float! [
+			prin-float as-float list/value
+		]
+		if list/type = type-float32! [
+			prin-float32 as-float32 list/value
+		]
 		if list/type = type-byte! [
 			prin-byte as-byte list/value
 		]
 		if list/type = type-c-string! [
 			prin as-c-string list/value
 		]
-		if list/type > 4 [
-			prin-hex list/value
-		]
+		;if list/type > 4 [
+		;	prin-hex list/value
+		;]
 		list: list + 1
 		count: count - 1
 		if all [spaced? count <> 0][prin " "]

diff --git a/red-system/targets/IA-32.r b/red-system/targets/IA-32.r
@@ -32,6 +32,15 @@ make target-class [
 		>				 #{0F}		#{07}
 	]
 
+	on-global-prolog: func [runtime? [logic!]][
+		; TBD: load control word from system/fpu/control-word
+		unless runtime? [
+			emit #{9BDBE3}							;-- FINIT			; init x87 FPU
+			emit #{BDE2}							;-- FNCLEX			; reset exception flags
+			;emit #{}								;-- FLDCW <word>	; load 16-bit control word
+		]
+	]
+
 	add-condition: func [op [word!] data [binary!]][
 		op: either '- = third op: find conditions op [op/2][
 			pick op pick [2 3] signed?
@@ -489,7 +498,7 @@ make target-class [
 	]
 
 	emit-push: func [
-		value [char! logic! integer! word! block! string! tag! path! get-word! object!]
+		value [char! logic! integer! word! block! string! tag! path! get-word! object! decimal!]
 		/with cast [object!]
 		/local spec type
 	][
@@ -498,6 +507,9 @@ make target-class [
 
 		switch type?/word value [
 			tag! [									;-- == <last>
+				if find [float! float64!] compiler/last-type/1 [
+					emit #{52}						;-- PUSH edx			; low part of 64-bit float
+				]															; high part in EAX
 				emit #{50}							;-- PUSH eax
 			]
 			logic! [
@@ -520,11 +532,27 @@ make target-class [
 					emit to-bin32 value	
 				]
 			]
+			decimal! [
+				value: IEEE-754/to-binary64 value
+				emit #{68}							;-- PUSH low part of 64-bit float
+				emit copy/part value 4
+				emit #{68}							;-- PUSH high part		
+				emit at value 5
+
+			]
 			word! [
-				type: first compiler/get-variable-spec value
-				emit-variable value
-					#{FF35}						;-- PUSH [value]		; global
-					#{FF75}						;-- PUSH [ebp+n]		; local
+				type: compiler/get-variable-spec value
+				either compiler/any-float? type [
+					emit #{83EC08}					;-- SUB esp, 8		@@ wide-aware
+					emit-variable value
+						#{DD05}						;-- FLD [value]			; global
+						#{DD45}						;-- FLD [ebp+n]			; local
+					emit #{DD1C24}					;-- FSTP [esp]			; push double on stack
+				][
+					emit-variable value
+						#{FF35}						;-- PUSH [value]		; global
+						#{FF75}						;-- PUSH [ebp+n]		; local
+				]
 			]
 			get-word! [
 				emit #{68}							;-- PUSH &value
@@ -947,6 +975,16 @@ make target-class [
 			emit-push either block? arg [<last>][arg]
 		]
 	]
+
+	emit-get-float-result: func [fspec [block!]][
+		ret-type: select fspec/4 compiler/return-def
+		if all [ret-type compiler/any-float? ret-type][		; @@ adapt for float32, only EAX!!
+			emit #{83EC08}							;-- SUB esp, 8		@@ width-aware
+			emit #{DD1C24}							;-- FSTP [esp]		@@ width-aware
+			emit-pop								;-- POP eax			;  high part of 64-bit float
+			emit-restore-last						;-- POP edx			;  low part 
+		]
+	]
 
 	emit-call-syscall: func [args [block!] fspec [block!]][
 		switch compiler/job/syscall [
@@ -981,6 +1019,7 @@ make target-class [
 				if fspec/1 >= 6 [emit #{5D}]		;-- POP ebp			; restore frame pointer
 			]
 		]
+		emit-get-float-result fspec
 	]
 
 	emit-call-import: func [args [block!] fspec [block!] spec [block!]][
@@ -994,7 +1033,8 @@ make target-class [
 		]
 		if fspec/3 = 'cdecl [						;-- add calling cleanup when required
 			emit-cdecl-pop fspec args
-		]		
+		]
+		emit-get-float-result fspec
 	]
 
 	emit-call-native: func [args [block!] fspec [block!] spec [block!] /local total][
@@ -1012,6 +1052,7 @@ make target-class [
 		if fspec/3 = 'cdecl [						;-- in case of non-default calling convention
 			emit-cdecl-pop fspec args
 		]
+		emit-get-float-result fspec
 	]
 
 	emit-stack-align-prolog: func [args-nb [integer!] /local offset][

diff --git a/red-system/utils/IEEE-754.r b/red-system/utils/IEEE-754.r
@@ -0,0 +1,101 @@
+REBOL [
+	Title:    "Red/System IEEE-754 library"
+	Author:   "Nenad Rakocevic"
+	File: 	  %IEEE-754.r
+	Rights:   "Copyright (C) 2000-2011 Eric Long, Nenad Rakocevic. All rights reserved."
+	License:  "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
+	Comment:  {
+		64-bit split/to-native functions from http://www.nwlink.com/~ecotope1/reb/decimal.r
+		Added 32-bit support, compacted a bit the existing code.
+	}
+]
+
+IEEE-754: context [
+	split64: func [
+		"Returns block containing three components of double floating point value"
+		n [number!] /local sign exp frac
+	][
+		sign: either negative? n [n: negate n 1][0]
+
+		either zero? n [exp: frac: 0][
+
+			either zero? 1024 - exp: to integer! log-2 n [
+				exp: 1023
+			][
+				if positive? (2 ** exp) - n [exp: exp - 1]
+			]
+			frac: n / (2 ** exp)
+
+			either positive? exp: exp + 1023 [
+				frac: frac - 1         				; drop the first bit for normals
+				frac: frac * (2 ** 52) 				; make the remaining fraction an
+													; "integer"
+			][
+				frac: 2 ** (51 + exp) * frac  		; denormals
+				exp: 0
+			]
+		]
+		reduce [sign exp frac]
+	]
+
+	to-binary64: func [
+		"convert a numerical value into native binary format"
+		n  [number!]
+		/rev     "reverse binary output"
+		/local out sign exp frac
+	][
+		set [sign exp frac] split64 n
+		out: make binary! 8
+		loop 6 [
+			insert out to char! byte: frac // 256
+			frac: frac - byte / 256
+		]
+		insert out to char! exp // 16 * 16  + frac
+		insert out to char! exp / 16 + (128 * sign)
+		either rev [copy reverse out][out]
+	]
+
+	split32: func [
+		"Returns block containing three components of single floating point value"
+		n [number!] /local sign exp frac
+	][
+		sign: either negative? n [n: negate n 1][0]
+
+		either zero? n [exp: frac: 0][
+
+			either zero? 128 - exp: to integer! log-2 n [
+				exp: 127
+			][
+				if positive? (2 ** exp) - n [exp: exp - 1]
+			]
+			frac: n / (2 ** exp)
+
+			either positive? exp: exp + 127 [
+				frac: frac * (2 ** 23) 				; make the remaining fraction an "integer"					   
+				frac: frac + 1						;-- NR: adjust by one to get the right result
+			][
+				frac: 2 ** (22 + exp) * frac  		; denormals
+				exp: 0
+			]
+		]
+		reduce [sign exp frac]
+	]
+
+	to-binary32: func [
+		"convert a numerical value into native binary format"
+		n  [number!]
+		/rev     "reverse binary output"
+		/local out sign exp frac
+	][
+		set [sign exp frac] split32 n
+		out: make binary! 4
+		loop 2 [
+			insert out to char! byte: frac // 256
+			frac: frac - byte / 256
+		]
+		frac: to integer! frac
+		insert out to char! frac or shift/left to integer! even? exp 7
+		insert out to char! (shift exp 1) + (128 * sign)
+		either rev [copy reverse out][out]
+	]
+]