value-impl.red

Red [
	Title: 	"Red value slot implementation dump for Red inspector"
]

;---|----1----|----2----|----3----|----4----|----5----|----6----|----7----|-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; auxiliary functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

extract-bits: func [
	{extracts contiguous set of bits from integer, typically flags}
	i [integer!]	"flag word"
	s [integer!]	"start bit"
	w [integer!]	"width"
	return: [integer!]
	/local m		"mask"
][
	m: 1 << w - 1
	m: m << s
	return i and m >>> s
]

hex-digits: func [
	{convert integer to hexadecimal digits}
	i [integer!]	"to be converted"
	n [integer!]	"number of digits"
][
	copy/part at form to binary! i 11 - n n
]

print-series-flags: func [
	flg [integer!]		"series flag word"
	/local bits
][
;-- series flags --
;	31: 	used 			;-- 1 = used, 0 = free
;	30: 	type 			;-- always 0 for series-buffer!
;	29-28: 	insert-opt		;-- optimized insertions: 2 = head, 1 = tail, 0 = both
;   27:		mark			;-- mark as referenced for the GC (mark phase)
;   26:		lock			;-- lock series for active thread access only
;   25:		immutable		;-- mark as read-only
;   24:		big				;-- indicates a big series (big-frame!)
;	23:		small			;-- reserved
;	22:		stack			;-- series buffer is allocated on stack
;   21:		permanent		;-- protected from GC (system-critical series)
;   20:     fixed			;-- series cannot be relocated (system-critical series)
;	19:		complement		;-- complement flag for bitsets
;	18:		UTF-16 cache	;-- signifies that the string cache is UTF-16 encoded (UTF-8 by default)
;	17:		owned			;-- series is owned by an object
;	16-3: 	<reserved>
;	4-0:	unit			;-- size in bytes of atomic element stored in buffer
							;-- 0: UTF-8, 1: Latin1/binary, 2: UCS-2, 4: UCS-4, 16: block! cell
	prin " "
	unless zero? extract-bits flg 31 1 [prin "used "]
	unless zero? bits: extract-bits flg 28 2 [
		prin "insert-opt " prin hex-digits bits 1 prin " "
	]
	unless zero? extract-bits flg 27 1 [prin "mark "]
	unless zero? extract-bits flg 26 1 [prin "lock "]
	unless zero? extract-bits flg 25 1 [prin "immutable "]
	unless zero? extract-bits flg 24 1 [prin "big "]
	unless zero? extract-bits flg 22 1 [prin "stack "]
	unless zero? extract-bits flg 21 1 [prin "permanent "]
	unless zero? extract-bits flg 20 1 [prin "fixed "]
	unless zero? extract-bits flg 19 1 [prin "complement "]
	unless zero? extract-bits flg 18 1 [prin "UTF-16 "]
	unless zero? extract-bits flg 17 1 [prin "owned "]
	; unit bits may be zero, meaning UTF-8 encoded string
	bits: extract-bits flg 0 5
		prin "unit " prin hex-digits bits 2 prin " "
	print ""
]

print-slot-flags: func [
	{print flags of value slot header}
	hdr [integer!]	"first element of value slot"
	/local bits
][
;-- cell header bits layout --
;	31:		lock			;-- lock series for active thread access only
;	30:		new-line		;-- new-line (LF) marker (before the slot)
;	29-25:	arity			;-- arity for routine! functions.
;	24:		self?			;-- self-aware context flag
;	23:		node-body		;-- op! body points to a block node (instead of native code)
;	22-19:	tuple-size		;-- size of tuple
;	18:		series-owned	;-- mark a series owned by an object
;	17:		owner			;-- indicate that an object is an owner
;	16:		native! op		;-- operator is made from a native! function
;	15:		extern flag		;-- routine code is external to Red (from FFI)
;	14-8:	<reserved>
;	7-0:	datatype ID		;-- datatype number

	; datatype ID need not be printed here, type name is printed elsewhere
	unless zero? hdr and FFFFFF00h [
		prin " "
		unless zero? extract-bits hdr 31 1 [prin "lock "]
		unless zero? extract-bits hdr 30 1 [prin "new-line "]
		unless zero? bits: extract-bits hdr 25 5 [
			prin "arity " prin hex-digits bits 2 prin " "
		]
		unless zero? extract-bits hdr 24 1 [prin "self? "]
		unless zero? extract-bits hdr 23 1 [prin "node-body "]
		unless zero? bits: extract-bits hdr 19 4 [
			prin "tuple-size " prin hex-digits bits 1 prin " "
		]
		unless zero? extract-bits hdr 18 1 [prin "series-owned "]
		unless zero? extract-bits hdr 17 1 [prin "owner "]
		unless zero? extract-bits hdr 16 1 [prin "native! op "]
		unless zero? extract-bits hdr 15 1 [prin "external"]
	]
	print ""
]

print-cache: func [
	{print c-string cache, 0-terminated byte string in UTF-8 encoding}
	addr [integer!]		"start address"
	/local ch
][
	print "showing cache ..."
	until [
		ch: FFh and deref addr
		prin hex-digits ch 2 prin " "
		addr: addr + 1
		ch = 0
	]
	print ""
]

print-type-struct: func [
	{uniform printout of contents of red-<type>! structs}
	addr [integer!]		"the hardware address of the struct!"
	/local
		hdr [integer!]	"slot header"
		tn [integer!]	"type number"
		td [block!]		"type data"
		ty [word!]		"type"
		fn [block!]		"red-<type> struct field names"
		i [integer!]	"counter"
][
	hdr: deref addr
	tn: type-nr-mask and hdr
	td: copy/part at types-table 2 * tn - 1 2
	ty: td/1
	fn: second find structures-table td/2
	print ["value slot of type" ty]
	prin [hex-digits addr 8 hex-digits hdr 8 "header"]
	print-slot-flags hdr
	repeat i 3 [
		print [
			hex-digits 4 * i + addr 8
			hex-digits deref 4 * i + addr 8
			; fn data is protected against emptyness
			; this for case of float! that takes two words for one field
			; occurs also in time! and date!
			any [fn/:i ""]
		]
	]	
]

print-series-buffer: func [
	{uniform printout of series buffer}
	addr [integer!]		"the hardware address of the series buffer"
	/local flg
][
	flg: deref addr
	print "series buffer ..."
	prin [hex-digits addr 8 hex-digits flg 8 "flags"]
	print-series-flags flg
	print [
		hex-digits addr + series-offset-offset 8
		hex-digits deref addr + series-offset-offset 8 "offset"
	]
	print [
		hex-digits addr + series-tail-offset 8
		hex-digits deref addr + series-tail-offset 8 "tail"]
]

get-current-context: routine [
	{get current context from context node field}
	addr [integer!]
	return: [integer!]
	/local np stk ctx
][
	np: as int-ptr! addr
	stk: as series! np/value
	ctx: as red-context! stk/offset
	return as integer! ctx
]

get-slot-addr: routine [
	{get slot address for value that word refers to}
	wd [word!]		"word that is bound"
	return: [integer!]
	/local stk ctx vals
][
	stk: as series! wd/ctx/value
	ctx: as red-context! stk/offset
	vals: as series! ctx/values/value
	return 16 * wd/index + as integer! vals/offset
]

get-symbol: routine [
	{get symbol from symbol table at index idx}
	idx [integer!]		"index in symbol table"
	return: [integer!]
	/local s sym
][
	s: GET_BUFFER(symbols)
	sym: as red-symbol! s/offset + idx - 1
	return as integer! sym
]

deref: routine [
	{get value at given address}
	addr [integer!]
	return: [integer!]
	/local p
][
	p: as pointer! [integer!] addr
	return p/value
]

depth-counter: does [
	switch/default length? recur-stack [
		0 [""]
		1 [form first recur-stack]
		2 [append append form first recur-stack "." form second recur-stack]
	][
		form to-tuple recur-stack
	]
]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; main functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

print-context: func [
	{print information about a context}
	addr [integer!]		"context node"
	/local ctx syms vals
][
	ctx: get-current-context addr
	print "showing context ..."
	print-type-struct ctx
	syms: deref ctx + context-symbols-offset
	print "showing symbols ..."
	print-block syms
	vals: deref ctx + context-values-offset
	unless vals = 0 [
		print "showing values ..."
		print-block vals
	]
]

print-symbol: func [
	{print a symbol table entry, followed by the string series of the name}
	idx [integer!]		"symbol index"
	/local sym node
][
	sym: get-symbol idx
	print "showing symbol ..."
	print-type-struct sym
	node: deref sym + symbol-node-offset
	print-string node
	unless 0 = deref sym + symbol-cache-offset [
		print-cache deref sym + symbol-cache-offset
	]
]

print-string: func [
	{print the elements of a string series, including for vector}
	np [integer!]		"node pointer"
	/local sb ptr tl sz nr
][
	print "following node ..."
	sb: deref np
	print-series-buffer sb
	ptr: deref sb + series-offset-offset
	tl: deref sb + series-tail-offset
	sz: unit-size-mask and deref sb 
	if sz = 0 [
		sz: 1
		print "UTF-8 encoding!"
	]
	nr: tl - ptr / sz
	
	print [nr "string series elements follow ..."]
	
	while [ptr < tl][
		prin hex-digits ptr 8 prin " "
		; vectors are treated as string series
		; a vector of floats has 8 bytes (2 words) per element
		either sz < 8
		[	
			print hex-digits deref ptr 2 * sz
		][
			print hex-digits deref ptr 8
			prin hex-digits ptr + 4 8 prin " "
			print hex-digits deref ptr + 4 8
		]
		ptr: ptr + sz
	]
]

print-block: func [
	{print the value slots in a block or paren etc.}
	np [integer!]		"node pointer"
	/local sb ptr tl sz nr
][
	insert tail recur-stack 0
	sb: deref np
	print-series-buffer sb
	ptr: deref sb + series-offset-offset
	tl: deref sb + series-tail-offset
	; unit size for all block series is 16; set as constant slot-size
	sz: slot-size
	nr: tl - ptr / sz
	
	print [nr "block series elements follow ..."]

	while [ptr < tl][
		print-slot ptr
		ptr: ptr + sz
	]
	
	clear back tail recur-stack
	print ["end-------------------------" depth-counter "------------------------end"]
]

print-slot: func [
	{print a hex dump of the value slot at given hardware address}
	addr [integer!]
][
	unless empty? recur-stack [
		change back tail recur-stack (last recur-stack) + 1
	]
	print ["----------------------------" depth-counter "---------------------------"]
	print-type-struct addr
	
	; for most non-direct types, there is further information to be shown
	switch type-name type-nr-mask and deref addr [
		block!
		paren!
		path!
		lit-path!
		set-path!
		get-path! [
			print "following block node ..."
			print-block deref addr + block-node-offset
		]
		string!
		file!
		url!
		tag!
		email! [
			print-string deref addr + string-node-offset
			unless 0 = deref addr + string-cache-offset [
				print-cache deref addr + string-cache-offset
			]
		]
		vector!
		binary!
		bitset! [
			print-string deref addr + string-node-offset
		]
		object!
		error! [
			print-context deref addr + object-ctx-offset
		]
		word!
		lit-word!
		set-word!
		get-word!
		refinement!
		issue! [
			print-symbol deref addr + symbol-node-offset
		]
		action!
		native!
		op! [
		]
		function! [
			print-context deref addr + function-ctx-offset
		]
		routine! [
		]
		hash!
		map! [
			print "following hash node ..."
			print-block deref addr + hash-node-offset
		]
	]
]