/red-system/targets/target-class.r

  1REBOL [
  2	Title:   "Red/System code emitter base object"
  3	Author:  "Nenad Rakocevic"
  4	File: 	 %target-class.r
  5	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
  6	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
  7]
  8
  9target-class: context [
 10	target: little-endian?: struct-align: ptr-size: void-ptr: none ; TBD: document once stabilized
 11	default-align: stack-width: branch-offset-size: none		   ; TBD: document once stabilized
 12	
 13	on-global-prolog: 		 none					;-- called at start of global code section
 14	on-global-epilog: 		 none					;-- called at end of global code section
 15	on-finalize:	  		 none					;-- called after all sources are compiled
 16	on-root-level-entry:	 none					;-- called after a root level expression or directive is compiled
 17	emit-stack-align-prolog: none					;-- align stack on imported function calls
 18	emit-stack-align-epilog: none					;-- unwind aligned stack
 19	
 20	compiler: 	none								;-- just a short-cut
 21	width: 		none								;-- current operand width in bytes
 22	signed?: 	none								;-- TRUE => signed op, FALSE => unsigned op
 23	last-saved?: no									;-- TRUE => operand saved in another register
 24	verbose:  	0									;-- logs verbosity level
 25	
 26	emit-casting: emit-call-syscall: emit-call-import:
 27	emit-call-native: emit-not: emit-push: emit-pop:
 28	emit-operation: none							;-- just pre-bind word to avoid contexts issue
 29	
 30	comparison-op: [= <> < > <= >=]
 31	math-op:	   [+ - * / // ///]
 32	bitwise-op:	   [and or xor]
 33	bitshift-op:   [>> << -**]
 34	
 35	opp-conditions: [
 36	;-- condition ------ opposite condition --
 37		overflow?		 not-overflow?
 38		not-overflow?	 overflow?			
 39		=				 <>
 40		<>				 =
 41		even?			 odd?
 42		odd?			 even?
 43		<				 >=
 44		>=				 <
 45		<=				 >
 46		>				 <=
 47	]
 48	
 49	opposite?: func [cond [word!]][
 50		first select/skip opp-conditions cond 2
 51	]
 52	
 53	power-of-2?: func [n [integer! char!]][
 54		if all [
 55			n: to integer! n
 56			positive? n
 57			zero? n - 1 and n
 58		][
 59			to integer! log-2 n
 60		]
 61	]
 62
 63	emit: func [bin [binary! char! block!]][
 64		if verbose >= 4 [print [">>>emitting code:" mold bin]]
 65		append emitter/code-buf bin
 66	]
 67	
 68	emit-reloc-addr: func [spec [block!]][
 69		append spec/3 emitter/tail-ptr				;-- save reloc position
 70		emit void-ptr								;-- emit void addr, reloc later		
 71		unless empty? emitter/chunks/queue [				
 72			append/only 							;-- record reloc reference
 73				second last emitter/chunks/queue
 74				back tail spec/3					
 75		]
 76	]
 77
 78	emit-variable: func [
 79		name [word! object!] gcode [binary!] lcode [binary! block!] 
 80		/local offset
 81	][
 82		if object? name [name: compiler/unbox name]
 83		
 84		either offset: select emitter/stack name [
 85			if any [								;-- local variable case
 86				offset < -128
 87				offset > 127
 88			][
 89				compiler/throw-error "#code generation error: overflow in emit-variable"
 90			]
 91			offset: skip debase/base to-hex offset 16 3	; @@ just to-char ??
 92			either block? lcode [
 93				emit reduce bind lcode 'offset
 94			][
 95				emit lcode
 96				emit offset
 97			]
 98		][											;-- global variable case
 99			emit gcode
100			emit-reloc-addr emitter/symbols/:name
101		]
102	]
103	
104	get-width: func [operand type /local value][
105		reduce [
106			emitter/size-of? value: case [
107				type 	[operand]
108				'else 	[			
109					value: first compiler/get-type operand
110					either value = 'any-pointer! ['pointer!][value]
111				]
112			]
113			value
114		]
115	]
116	
117	set-width: func [operand /type /local value][
118		value: get-width operand type
119		width: value/1
120		signed?: emitter/signed? value/2
121	]
122	
123	with-width-of: func [value body [block!] /alt /local old][
124		old: width
125		set-width compiler/unbox value
126		do body
127		width: old
128		if all [alt object? value][emit-casting value yes]	;-- casting for right operand
129	]
130	
131	implicit-cast: func [arg /local right-width][
132		right-width: first get-width arg none
133		
134		if all [width = 4 right-width = 1][			;-- detect byte! -> integer! implicit casting
135			arg: make object! [action: 'type-cast type: [integer!] data: arg]
136			emit-casting arg yes					;-- type cast right argument
137		]
138	]
139	
140	emit-call: func [name [word!] args [block!] sub? [logic!] /local spec fspec res][
141		if verbose >= 3 [print [">>>calling:" mold name mold args]]
142
143		fspec: select compiler/functions name
144		spec: any [select emitter/symbols name next fspec]
145		type: first spec
146
147		switch type [
148			syscall [
149				emit-call-syscall args fspec
150			]
151			import [
152				emit-call-import args fspec spec
153			]
154			native [
155				emit-call-native args fspec spec
156			]
157			inline [
158				if block? args/1 [args/1: <last>]	;-- works only for unary functions	
159				do select [
160					not			[emit-not args/1]
161					push		[emit-push args/1]
162					pop			[emit-pop]
163				] name
164				if name = 'not [res: compiler/get-type args/1]
165			]
166			op	[
167				emit-operation name args
168				if sub? [emitter/logic-to-integer name]
169				unless find comparison-op name [		;-- comparison always return a logic!
170					res: any [
171						;all [object? args/1 args/1/type]
172						all [not sub? block? args/1 compiler/last-type]
173						compiler/get-type args/1	;-- other ops return type of the first argument	
174					]
175				]
176			]
177		]
178		res
179	]
180]