Interpreter.icl 8.75 KB
Newer Older
1 2 3
implementation module ABC.Interpreter

import StdArray
4
import StdClass
5 6
import StdFile
import StdInt
7
import StdList
8
import StdMisc
9
import StdOrdList
10 11

import Data._Array
12
import Data.Either
13
import Data.Error
14
from Data.Func import `on`, on
15 16 17 18 19 20 21 22 23 24 25 26
import Data.Maybe
import System.CommandLine
import System.File
import System.FilePath
import System._Pointer

import graph_copy_with_names
import symbols_in_program

import ABC.Interpreter.Internal
import ABC.Interpreter.Util

27 28
:: *SerializedGraph =
	{ graph    :: !*String
29 30
	, descinfo :: !{#DescInfo}
	, modules  :: !{#String}
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
	, bytecode :: !String
	}

// The arguments are:
// - Pointer to C function;
// - Argument for function (in our case, pointer to the interpret node)
// - Pointer to rest of the finalizers (dealt with in the RTS)
:: Finalizer = Finalizer !Int !Int !Int
:: InterpretedExpression :== Finalizer
:: *InterpretationEnvironment = E.a:
	{ ie_finalizer :: !Finalizer
	, ie_snode_ptr :: !Int
	, ie_snodes    :: !*{a}
	}

46 47
serialize_for_interpretation :: a !FilePath !*World -> *(!SerializedGraph, !*World)
serialize_for_interpretation graph bcfile w
48
# (graph,descs,mods) = copy_to_string_with_names graph
49 50 51 52

# (bytecode,w) = readFile bcfile w
| isError bytecode = abort "Failed to read the bytecode file\n"
# bytecode = fromOk bytecode
53

Camil Staps's avatar
Camil Staps committed
54 55
#! (len,bytecodep) = strip_bytecode bytecode {#symbol_name di mods \\ di <-: descs}
#! bytecode = derefCharArray bytecodep len
Camil Staps's avatar
Camil Staps committed
56 57
| free_to_false bytecodep = abort "cannot happen\n"

58 59
# rec =
	{ graph    = graph
60 61
	, descinfo = descs
	, modules  = mods
62 63 64
	, bytecode = bytecode
	}
= (rec, w)
Camil Staps's avatar
Camil Staps committed
65 66 67 68 69 70
where
	symbol_name :: !DescInfo !{#String} -> String
	symbol_name {di_prefix_arity_and_mod,di_name} mod_a
	# prefix_n = di_prefix_arity_and_mod bitand 0xff
	# module_n = (di_prefix_arity_and_mod >> 8)-1
	# module_name = mod_a.[module_n]
71
	= make_symbol_name module_name di_name (min prefix_n PREFIX_D) +++ "\0"
Camil Staps's avatar
Camil Staps committed
72 73 74
	where
		PREFIX_D = 4

Camil Staps's avatar
Camil Staps committed
75
	strip_bytecode :: !String !{#String} -> (!Int, !Pointer)
Camil Staps's avatar
Camil Staps committed
76 77 78
	strip_bytecode bytecode descriptors = code {
		ccall strip_bytecode "sA:VIp"
	}
79 80 81 82 83

deserialize :: !SerializedGraph !FilePath !*World -> *(a, !*World)
deserialize {graph,descinfo,modules,bytecode} thisexe w
# (host_syms,w) = accFiles (read_symbols thisexe) w

84
# pgm = parse host_syms bytecode
85
| isNothing pgm = abort "Failed to parse bytecode\n"
86
# pgm = fromJust pgm
87
# int_syms = {#s \\ s <- getInterpreterSymbols pgm}
88
# int_syms = {#lookup_symbol_value d modules int_syms \\ d <-: descinfo}
89 90 91 92 93

# stack = malloc (IF_INT_64_OR_32 8 4 * STACK_SIZE)
# asp = stack
# bsp = stack + IF_INT_64_OR_32 8 4 * (STACK_SIZE-1)
# csp = stack + IF_INT_64_OR_32 4 2 * STACK_SIZE
94
# heap = malloc (IF_INT_64_OR_32 8 4 * (HEAP_SIZE+4))
95 96 97 98
# ie_settings = build_interpretation_environment
	pgm
	heap HEAP_SIZE stack STACK_SIZE
	asp bsp csp heap
99
# graph_node = string_to_interpreter int_syms graph ie_settings
100
#! (ie,_) = make_finalizer ie_settings
101
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=unsafeCreateArray 1}
102 103 104
= (interpret ie (Finalizer 0 0 graph_node), w)
where
	getInterpreterSymbols :: !Pointer -> [Symbol]
Camil Staps's avatar
Camil Staps committed
105
	getInterpreterSymbols pgm = takeWhile (\s -> size s.symbol_name <> 0)
106
		[getSymbol i \\ i <- [0..get_symbol_table_size pgm-1]]
107
	where
108
		symbol_table = get_symbol_table pgm
109 110 111

		getSymbol :: !Int -> Symbol
		getSymbol i
112 113
		#! offset = symbol_table + i * IF_INT_64_OR_32 16 8 /* size of struct host_symbol */
		#! loc = derefInt offset
114 115 116
		#! name = derefString (derefInt (offset + IF_INT_64_OR_32 8 4))
		= {symbol_name=name, symbol_value=loc}

117 118 119
		get_symbol_table_size :: !Pointer -> Int
		get_symbol_table_size pgm = code {
			ccall get_symbol_table_size "p:I"
120
		}
121

122 123 124
		get_symbol_table :: !Pointer -> Pointer
		get_symbol_table pgm = code {
			ccall get_symbol_table "p:p"
125 126
		}

127 128 129
	string_to_interpreter :: !{#Int} !String !Pointer -> Pointer
	string_to_interpreter symbol_values graph ie = code {
		ccall string_to_interpreter "ASp:p"
130
	}
131

132 133 134 135 136 137 138 139 140 141
	lookup_symbol_value :: !DescInfo !{#String} !{#Symbol} -> Int
	lookup_symbol_value {di_prefix_arity_and_mod,di_name} mod_a symbols
		# prefix_n = di_prefix_arity_and_mod bitand 0xff
		# module_n = (di_prefix_arity_and_mod >> 8)-1
		# module_name = mod_a.[module_n]
		| prefix_n<PREFIX_D
			# symbol_name = make_symbol_name module_name di_name prefix_n
			# symbol_value = get_symbol_value symbol_name symbols
			| prefix_n<=1
				| symbol_value== -1
142
					= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
143 144
					= symbol_value
				| symbol_value== -1
145
					= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
146 147 148 149
					= symbol_value+2
			# symbol_name = make_symbol_name module_name di_name PREFIX_D
			# symbol_value = get_symbol_value symbol_name symbols
			| symbol_value== -1
150
				= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
151 152 153 154 155
				# arity = prefix_n - PREFIX_D
				= symbol_value+(arity*8*2)+2
	where
		PREFIX_D = 4

156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
STACK_SIZE :== (512 << 10) * 2
HEAP_SIZE :== 2 << 20

get_start_rule_as_expression :: !FilePath !*World -> *(a, *World)
get_start_rule_as_expression filename w
# ([prog:_],w) = getCommandLine w
# (syms,w) = accFiles (read_symbols prog) w
# (bc,w) = readFile filename w
| isError bc = abort "Failed to read the file\n"
# bc = fromOk bc
# pgm = parse syms bc
| isNothing pgm = abort "Failed to parse program\n"
# pgm = fromJust pgm
# stack = malloc (IF_INT_64_OR_32 8 4 * STACK_SIZE)
# asp = stack
# bsp = stack + IF_INT_64_OR_32 8 4 * (STACK_SIZE-1)
# csp = stack + IF_INT_64_OR_32 4 2 * STACK_SIZE
# heap = malloc (IF_INT_64_OR_32 8 4 * HEAP_SIZE)
# ie_settings = build_interpretation_environment
	pgm
	heap HEAP_SIZE stack STACK_SIZE
	asp bsp csp heap
# start_node = build_start_node ie_settings
#! (ie,_) = make_finalizer ie_settings
180
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=unsafeCreateArray 1}
181 182 183 184 185 186
= (interpret ie (Finalizer 0 0 start_node), w)
	// Obviously, this is not a "valid" finalizer in the sense that it can be
	// called from the garbage collector. But that's okay, because we don't add
	// it to the finalizer_list anyway. This is just to ensure that the first
	// call to interpret gets the right argument.

187 188 189 190
build_interpretation_environment :: !Pointer !Pointer !Int !Pointer !Int !Pointer !Pointer !Pointer !Pointer -> Pointer
build_interpretation_environment pgm heap hsize stack ssize asp bsp csp hp = code {
	ccall build_interpretation_environment "ppIpIpppp:p"
}
191

192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
build_start_node :: !Pointer -> Pointer
build_start_node ie = code {
	ccall build_start_node "p:p"
}

make_finalizer :: !Int -> (!.Finalizer,!Int)
make_finalizer ie_settings = code {
	push_finalizers
	ccall get_interpretation_environment_finalizer ":p"
	push_a_b 0
	pop_a 1
	build_r e__system_kFinalizer 0 3 0 0
	pop_b 3
	set_finalizers
	pushI 0
}
208 209 210 211 212 213 214

graphToFile :: !*SerializedGraph !*File -> *(!*SerializedGraph, !*File)
graphToFile {graph,descinfo,modules,bytecode} f
# (graph_cpy,graph,graph_size) = copy graph
# f = f <<< graph_size
# f = f <<< {#c \\ c <- graph_cpy}

215 216
# f = f <<< size descinfo
# f = writeArray (\di f -> f <<< di.di_prefix_arity_and_mod <<< size di.di_name <<< di.di_name) descinfo (size descinfo-1) f
217

218 219
# f = f <<< size modules
# f = writeArray (\m f -> f <<< size m <<< m) modules (size modules-1) f
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237

# f = f <<< size bytecode
# f = f <<< bytecode

= ({graph=graph,descinfo=descinfo,modules=modules,bytecode=bytecode},f)
where
	copy :: !*(b a) -> *(![a], !*b a, !Int) | Array b a
	copy arr
	# (s,arr) = usize arr
	# (cpy,arr) = copy (s-1) arr []
	= (cpy,arr,s)
	where
		copy :: !Int !*(b a) ![a] -> *(![a], !*b a) | Array b a
		copy -1 arr cpy = (cpy, arr)
		copy i  arr cpy
		# (x,arr) = arr![i]
		= copy (i-1) arr [x:cpy]

238 239 240
	writeArray :: !(e *File -> *File) !(arr e) !Int !*File -> *File | Array arr e
	writeArray write xs -1 f = f
	writeArray write xs i f = writeArray write xs (i-1) (write xs.[i] f)
241 242 243 244 245 246

graphFromFile :: !*File -> *(!Either String *SerializedGraph, !*File)
graphFromFile f
# (graph,f) = readString f

# (_,descinfo_size,f) = freadi f
247
# (descinfo,f) = readArray readDescInfo (descinfo_size-1) (unsafeCreateArray descinfo_size) f
248 249

# (_,modules_size,f) = freadi f
250
# (modules,f) = readArray readString (modules_size-1) (unsafeCreateArray modules_size) f
251 252 253 254 255 256 257 258 259 260

# (bytecode,f) = readString f

# (end,f) = fend f
| not end = (Left "EOF not found after end of graph",f)
# (err,f) = ferror f
| err = (Left "I/O error while reading graph",f)

= (Right {graph=graph,descinfo=descinfo,modules=modules,bytecode=bytecode},f)
where
261 262 263
	readArray :: !(*File -> *(a, *File)) !Int !*(arr a) !*File -> *(!*arr a, !*File) | Array arr a
	readArray _ -1 xs f = (xs,f)
	readArray read i xs f
264
	# (x,f) = read f
265
	= readArray read (i-1) {xs & [i]=x} f
266 267 268 269 270 271 272 273 274 275 276

	readDescInfo :: !*File -> *(!DescInfo, !*File)
	readDescInfo f
	# (_,prefix_arity_and_mod,f) = freadi f
	# (name,f) = readString f
	= ({di_prefix_arity_and_mod=prefix_arity_and_mod, di_name=name}, f)

	readString :: !*File -> *(!.String, !*File)
	readString f
	# (_,size,f) = freadi f
	= freads f size
Camil Staps's avatar
Camil Staps committed
277 278 279 280 281

malloc :: !Int -> Pointer
malloc _ = code {
	ccall malloc "I:p"
}