target.icl 24.1 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
implementation module target

import StdEnv
import StdMaybe
import interpretergen

:: Target =
	{ output      :: ![String]
	, instrs      :: ![String]
	, var_counter :: !Int
	}

:: ExprList
	= E.t: (--) infixr !(Expr t) ExprList
	| ELNil

:: Expr t
	= EUnreachable
	| ENop

	| EBlock
	| EBr !Label
	| EIf !(Expr TWord)
	| EThen
25
	| EElse
26 27 28 29
	| EBr_if !Int !(Expr TWord)
	| EEnd
	| ECall !Label !ExprList

30
	| E.u: ESelect !(Expr u) !(Expr u) !(Expr TWord) & typename u
31 32 33 34

	| Ei64_const !Int

	| ELocal !String !Label
35
	| EGlobal !String !Label
36 37 38 39 40 41 42

	| ETee !(Expr t) !(Expr t)
	| E.u: ESet !(Expr u) !(Expr u)

	| E.u: Eload32 !(Expr u)
	| E.u: Estore32 !(Expr u) !(Expr TWord)

43 44
	| EDeref !String !String !(Expr (TPtr t)) !(Expr TWord)
	| ERef !String !String !(Expr t) !(Expr TWord)
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75

	| Ei64_reinterpret_f64 !(Expr TReal)
	| Ei64_trunc_f64_s !(Expr TReal)
	| Ef64_convert_i64_s !(Expr TInt)
	| Ef64_reinterpret_i64 !(Expr TInt)

	| Eadd !(Expr t) !(Expr t)
	| Esub !(Expr t) !(Expr t)
	| Emul !(Expr t) !(Expr t)
	| Ediv_s !(Expr t) !(Expr t)
	| Erem_s !(Expr t) !(Expr t)

	| Eeqz !(Expr t)

	| Eabs !(Expr t)
	| Efloor !(Expr t)
	| Eneg !(Expr t)
	| Esqrt !(Expr t)

	| E.u: Eeq   !(Expr u) !(Expr u)
	| E.u: Ene   !(Expr u) !(Expr u)
	| E.u: Elt_s !(Expr u) !(Expr u)
	| E.u: Egt_s !(Expr u) !(Expr u)
	| E.u: Ele_s !(Expr u) !(Expr u)
	| E.u: Ege_s !(Expr u) !(Expr u)

	| Eand !(Expr t) !(Expr t)
	| Eor !(Expr t) !(Expr t)
	| Exor !(Expr t) !(Expr t)
	| Eshl !(Expr t) !(Expr TWord)
	| Eshr_s !(Expr t) !(Expr t)
76
	| Eshr_u !(Expr t) !(Expr t)
77

Camil Staps's avatar
Camil Staps committed
78 79
	| Elit !String !String

80 81 82 83 84 85 86 87 88 89 90 91
:: Label :== String

instance toString (Expr t)
where
	toString e = case e of
		EUnreachable -> "(unreachable)"
		ENop         -> "(nop)"

		EBlock     -> "(block"
		EBr id     -> "(br $"+++id+++")"
		EIf c      -> "(if "+++i64_to_cond c
		EThen      -> "(then"
92
		EElse      -> "(else"
93 94 95 96
		EBr_if l c -> "(br_if "+++toString l+++toString c+++")"
		EEnd       -> ")"
		ECall l as -> "(call $"+++l+++print_args (starts_with 0 "clean_" l) as+++")"

97
		ESelect t e c -> "(select"+++toString t+++toString e+++toString c+++")"
98 99 100

		Ei64_const i -> "(i64.const "+++toString i+++")"

101 102
		ELocal _ l  -> "(local.get $"+++l+++")"
		EGlobal _ l -> "(global.get $"+++l+++")"
103 104

		ETee v e -> case v of
105 106 107
			ELocal _ l
				-> "(local.tee $"+++l+++" "+++toString e+++")"
				-> abort "missing case in toString_ETee\n"
108
		ESet v e -> case v of
109
			EGlobal _ l
110 111 112
				-> "(global.set $"+++l+++" "+++toString e+++")"
			ELocal _ l
				-> "(local.set $"+++l+++" "+++toString e+++")"
113 114
			EDeref _ sw m (Ei64_const i) | i>=0
				-> "(i64.store"+++sw+++" offset="+++toString (i*8)+++" (i32.wrap_i64 "+++toString m+++")"+++i32_to_64 e+++")" // TODO: add bitwidth
115
			EDeref _ sw m i
116 117 118 119 120 121
				-> "(i64.store"+++sw+++" (i32.wrap_i64 (i64.add "+++toString m+++"(i64.mul "+++toString i+++" (i64.const "+++toString width+++"))))"+++i32_to_64 e+++")" // TODO: add bitwidth
				with
					width = case sw of
						"8"  -> 1
						"16" -> 2
						_    -> 8
122
				-> abort "missing case in toString_ESet\n"
123 124 125 126

		Eload32 i    -> "(i64.load (i32.wrap_i64 "+++toString i+++"))"
		Estore32 i e -> "(i64.store (i32.wrap_i64 "+++toString i+++")"+++i32_to_64 e+++")"

127 128
		EDeref lw sw m (Ei64_const i) | i >=0 // TODO: does not cover all cases, see e.g. is_record
			-> "(i64.load"+++lw+++" offset="+++toString (i*8)+++" (i32.wrap_i64 "+++toString m+++"))"
129 130 131 132 133 134 135 136
		EDeref lw sw m i
			-> "(i64.load"+++lw+++" (i32.wrap_i64 "+++toString (ERef lw sw m i)+++"))"
		ERef lw sw m i
			-> "(i64.add "+++toString m+++toString (Emul (Ei64_const width) i)+++")"
			with
				width = case sw of
					"8"  -> 1
					"16" -> 2
137
					""   -> 8
138 139 140 141 142 143

		Ei64_reinterpret_f64 r -> "(i64.reinterpret_f64 "+++toString r+++")"
		Ei64_trunc_f64_s r     -> "(i64.trunc_f64_s "+++toString r+++")"
		Ef64_convert_i64_s i   -> "(f64.convert_i64_s "+++toString i+++")"
		Ef64_reinterpret_i64 i -> "(f64.reinterpret_i64 "+++toString i+++")"

144 145 146 147 148
		Eadd a b   -> "("+++f_or_i64 a+++".add"+++concat [a,b]+++")"
		Esub a b   -> "("+++f_or_i64 a+++".sub"+++concat [a,b]+++")"
		Emul a b   -> "("+++f_or_i64 a+++".mul"+++concat [a,b]+++")"
		Ediv_s a b -> "("+++signed_op (f_or_i64 a) "div"+++concat [a,b]+++")"
		Erem_s a b -> "("+++f_or_i64 a+++".rem_s"+++concat [a,b]+++")"
149

150
		Eeqz e -> "("+++f_or_i64 e+++".eqz "+++toString e+++")"
151 152 153 154 155 156

		Eabs e   -> "("+++type e+++".abs "+++toString e+++")"
		Efloor e -> "("+++type e+++".floor "+++toString e+++")"
		Eneg e   -> "("+++type e+++".neg "+++toString e+++")"
		Esqrt e  -> "("+++type e+++".sqrt "+++toString e+++")"

157 158 159 160 161 162
		Eeq a b   -> "("+++f_or_i64 a+++".eq"+++concat [a,b]+++")"
		Ene a b   -> "("+++f_or_i64 a+++".ne"+++concat [a,b]+++")"
		Elt_s a b -> "("+++signed_op (f_or_i64 a) "lt"+++concat [a,b]+++")"
		Egt_s a b -> "("+++signed_op (f_or_i64 a) "gt"+++concat [a,b]+++")"
		Ele_s a b -> "("+++signed_op (f_or_i64 a) "le"+++concat [a,b]+++")"
		Ege_s a b -> "("+++signed_op (f_or_i64 a) "ge"+++concat [a,b]+++")"
163 164 165 166 167 168

		Eand a b   -> "("+++type a+++".and"+++concat [a,b]+++")"
		Eor a b    -> "("+++type a+++".or"+++concat [a,b]+++")"
		Exor a b   -> "("+++type a+++".xor"+++concat [a,b]+++")"
		Eshl a b   -> "("+++type a+++".shl"+++toString a+++toString b+++")"
		Eshr_s a b -> "("+++type a+++".shr_s"+++concat [a,b]+++")"
169
		Eshr_u a b -> "("+++type a+++".shr_u"+++concat [a,b]+++")"
Camil Staps's avatar
Camil Staps committed
170 171

		Elit _ l -> l
172 173 174
	where
		signed_op t op = if (t.[0]=='f') (t+++"."+++op) (t+++"."+++op+++"_s")

175 176 177 178 179
		f_or_i64 e = case type e of
			"i8"  -> "i64"
			"i16" -> "i64"
			t     -> t

180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
		i32_to_64 e = case type e of
			"i32"
				-> "(i64.extend_i32_s "+++toString e+++")"
				-> toString e
		i64_to_cond e = case type e of
			"i64"
				-> "(i32.eqz(i64.eqz "+++toString e+++"))"
				-> toString e

		starts_with i s1 s2
		| i==size s1     = True
		| i==size s2     = False
		| s1.[i]<>s2.[i] = False
		| otherwise      = starts_with (i+1) s1 s2

print_args :: !Bool !ExprList -> String
print_args ffi (a -- as)
| ffi && type a == "i64"
	= "(i32.wrap_i64 "+++toString a+++")"+++print_args ffi as
	= toString a+++print_args ffi as
print_args _ ELNil = ""

concat :: ![a] -> String | toString a
concat [x:xs] = foldl (\s x -> s+++toString x) (toString x) xs
concat [] = ""

type :: !(Expr t) -> String
type e = case type` e of
	Just t
		-> t
		-> print_val e
where
	type` :: !(Expr t) -> Maybe String
	type` e = case e of
214
		ESelect t e _ -> either t e
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247

		Ei64_const _ -> Just "i64"

		Ei64_reinterpret_f64 _ -> Just "i64"
		Ei64_trunc_f64_s _ -> Just "i64"
		Ef64_convert_i64_s _ -> Just "f64"
		Ef64_reinterpret_i64 _ -> Just "f64"

		Eadd a b -> either a b
		Esub a b -> either a b
		Emul a b -> either a b
		Ediv_s a b -> either a b
		Erem_s a b -> either a b

		Eeqz _ -> Just "i32"

		Eabs e -> type` e
		Efloor e -> type` e
		Eneg e -> type` e
		Esqrt e -> type` e

		Eeq   _ _ -> Just "i32"
		Ene   _ _ -> Just "i32"
		Elt_s _ _ -> Just "i32"
		Egt_s _ _ -> Just "i32"
		Ele_s _ _ -> Just "i32"
		Ege_s _ _ -> Just "i32"

		Eand a b -> either a b
		Eor a b -> either a b
		Exor a b -> either a b
		Eshl a b -> either a b
		Eshr_s a b -> either a b
248
		Eshr_u a b -> either a b
249

250 251
		ELocal t _  -> Just t
		EGlobal t _ -> Just t
252

253 254
		EDeref _ _ _ _ -> Just "i64" // TODO
		ERef _ _ _ _ -> Just "i64" // TODO
255 256 257 258 259

		ECall c _
			| c=="clean_strncmp" -> Just "i32"
			| otherwise -> Nothing

Camil Staps's avatar
Camil Staps committed
260 261
		Elit t _ -> Just t

262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
		_ -> Nothing
	where
		either :: !(Expr a) !(Expr b) -> Maybe String
		either a b = case type` a of
			Just t
				-> Just t
				-> type` b

	print_val :: !a -> String
	print_val _ = code {
		print "No type found for: "
		.d 1 0
		jsr _print_graph
		.o 0 0
		halt
	}

cast_expr :: !.a -> .b
cast_expr _ = code {
	no_op
}

start :: Target
start = {instrs=[], output=[], var_counter=0}

bootstrap :: ![String] -> [String]
bootstrap instrs = instrs

290 291 292
collect_instructions :: !Options ![Target] -> [String]
collect_instructions {instructions_order=Nothing} _ = abort "no abc instructions order specified\n"
collect_instructions {debug_instructions,instructions_order=Just instrs_order} is =
293 294 295 296 297 298 299 300 301
	start ++
	reverse [block_start i \\ i <- is] ++
	switch ++
	flatten [block_body i \\ i <- is] ++
	end
where
	start =
		[ "(module"
		, "(import \"clean\" \"memory\" (memory 1))"
302
		, "(func $clean_memcpy (import \"clean\" \"memcpy\") (param i32 i32 i32))"
303 304
		, "(func $clean_strncmp (import \"clean\" \"strncmp\") (param i32 i32 i32) (result i32))"
		, "(func $clean_putchar (import \"clean\" \"putchar\") (param i32))"
305
		, "(func $clean_print_int (import \"clean\" \"print_int\") (param i32 i32))"
306
		, "(func $clean_print_bool (import \"clean\" \"print_bool\") (param i32))"
307 308
		, "(func $clean_print_char (import \"clean\" \"print_char\") (param i32))"
		, "(func $clean_print_real (import \"clean\" \"print_real\") (param f64))"
309 310 311 312 313 314 315 316 317 318
		, "(func $clean_powR (import \"clean\" \"powR\") (param f64 f64) (result f64))"
		, "(func $clean_acosR (import \"clean\" \"acosR\") (param f64) (result f64))"
		, "(func $clean_asinR (import \"clean\" \"asinR\") (param f64) (result f64))"
		, "(func $clean_atanR (import \"clean\" \"atanR\") (param f64) (result f64))"
		, "(func $clean_cosR (import \"clean\" \"cosR\") (param f64) (result f64))"
		, "(func $clean_sinR (import \"clean\" \"sinR\") (param f64) (result f64))"
		, "(func $clean_tanR (import \"clean\" \"tanR\") (param f64) (result f64))"
		, "(func $clean_expR (import \"clean\" \"expR\") (param f64) (result f64))"
		, "(func $clean_lnR (import \"clean\" \"lnR\") (param f64) (result f64))"
		, "(func $clean_log10R (import \"clean\" \"log10R\") (param f64) (result f64))"
319
		, if debug_instructions "(func $clean_debug_instr (import \"clean\" \"debug_instr\") (param i32 i32))" ""
320
		, "(func $clean_illegal_instr (import \"clean\" \"illegal_instr\") (param i32 i32))"
321 322
		, "(func $clean_out_of_memory (import \"clean\" \"out_of_memory\"))"
		, "(func $clean_gc (import \"clean\" \"gc\") (param i32) (result i64))"
323
		, "(func $clean_halt (import \"clean\" \"halt\") (param i32 i32 i32))"
324 325 326 327 328 329 330
		, "(global $pc      (mut i64) (i64.const 0))"
		, "(global $asp     (mut i64) (i64.const 0))"
		, "(global $bsp     (mut i64) (i64.const 0))"
		, "(global $csp     (mut i64) (i64.const 0))"
		, "(global $hp      (mut i64) (i64.const 0))"
		, "(global $hp_size (mut i64) (i64.const 0))"
		, "(global $hp_free (mut i64) (i64.const 0))"
331 332 333 334 335
		, "(func (export \"get_asp\") (result i32) (i32.wrap_i64 (global.get $asp)))"
		, "(func (export \"get_bsp\") (result i32) (i32.wrap_i64 (global.get $bsp)))"
		, "(func (export \"get_csp\") (result i32) (i32.wrap_i64 (global.get $csp)))"
		, "(func (export \"get_hp\")  (result i32) (i32.wrap_i64 (global.get $hp)))"
		, "(global $vf0 (mut f64) (f64.const 0.0))" // only used in instructions like absR; so only one variable is enough
336
		] ++
337 338
		[ "(global $vi"+++toString n+++" (mut i64) (i64.const 0))"
		\\ n <- [0..maxList [i.var_counter \\ i <- is]-1]
339
		] ++
340 341 342 343 344 345 346 347
		[ "(func (export \"interpret\") (param i32 i32 i32 i32 i32 i32) (result i32)"
		, "(global.set $pc      (i64.extend_i32_u (local.get 0)))"
		, "(global.set $asp     (i64.extend_i32_u (local.get 1)))"
		, "(global.set $bsp     (i64.extend_i32_u (local.get 2)))"
		, "(global.set $csp     (i64.extend_i32_u (local.get 3)))"
		, "(global.set $hp      (i64.extend_i32_u (local.get 4)))"
		, "(global.set $hp_size (i64.extend_i32_u (local.get 5)))"
		, "(global.set $hp_free (i64.extend_i32_u (local.get 5)))"
348 349 350 351
		, "(loop $abc-loop"
		, "(block $abc-gc"
		]
	end =
352 353 354 355 356 357 358
		[ ")" // block abc-gc
		, "(global.set $vi0 (call $clean_gc (i32.wrap_i64 (global.get $asp))))"
		, "(global.set $hp (i64.shr_u (global.get $vi0) (i64.const 32)))"
		, "(if (i64.le_s (i64.and (global.get $vi0) (i64.const 0xffffffff)) (global.get $hp_free))"
		, "\t(then (call $clean_out_of_memory) (unreachable)))"
		, "(global.set $hp_free (i64.and (global.get $vi0) (i64.const 0xffffffff)))"
		, "(br $abc-loop)"
359 360 361 362 363 364 365
		, ")" // loop abc-loop
		, "(unreachable)"
		, ")" // func
		, ")" // module
		]

	block_start t = "(block $instr_"+++hd t.instrs
366
	block_body t = [")":head ++ reverse t.output]
367 368 369 370 371
	where
		head = reverse [";; "+++i \\ i <- t.instrs]

	switch =
		[ "(block $instr_illegal"
372 373 374
		, if debug_instructions
			"\t(call $clean_debug_instr (i32.wrap_i64 (global.get $pc)) (i32.load (i32.wrap_i64 (global.get $pc))))"
			""
375 376
		, "\t(br_table " +++
			foldr (+++) "" [find_label i is \\ i <- instrs_order] +++
377
			"$instr_illegal (i32.load (i32.wrap_i64 (global.get $pc))))"
378
		, ")"
379
		, "(call $clean_illegal_instr (i32.wrap_i64 (global.get $pc)) (i32.load (i32.wrap_i64 (global.get $pc))))"
380 381 382 383 384 385
		]
	where
		find_label i [t:ts]
		| isMember i t.instrs
			= "$instr_"+++hd t.instrs+++" "
			= find_label i ts
386
		find_label _ [] = "$instr_illegal "
387 388 389 390

append e t :== {t & output=[toString e:t.output]}

instr_unimplemented :: !Target -> Target
391
instr_unimplemented t = append "(call $clean_illegal_instr (i32.wrap_i64 (global.get $pc)) (i32.load (i32.wrap_i64 (global.get $pc))))" t
392 393

instr_halt :: !Target -> Target
394 395
instr_halt t = append "(return (i32.const 0))"
	(append "(call $clean_halt (i32.wrap_i64 (global.get $pc)) (i32.wrap_i64 (global.get $hp_free)) (i32.wrap_i64 (global.get $hp_size)))" t)
396 397

instr_divLU :: !Target -> Target
398
instr_divLU t = instr_unimplemented t // TODO
399 400

instr_mulUUL :: !Target -> Target
401
instr_mulUUL t = instr_unimplemented t // TODO
402 403 404 405 406

lit_word :: !Int -> Expr TWord
lit_word i = Ei64_const i

lit_char :: !Char -> Expr TChar
407
lit_char c = Ei64_const (toInt c)
408 409

lit_short :: !Int -> Expr TShort
410
lit_short i = Ei64_const i
411 412 413 414

lit_int :: !Int -> Expr TInt
lit_int i = Ei64_const i

415
instance to_word TChar    where to_word e = cast_expr e
416
instance to_word TInt     where to_word e = cast_expr e
417
instance to_word TShort   where to_word e = cast_expr e
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437
instance to_word (TPtr t) where to_word e = cast_expr e
instance to_word TReal    where to_word e = Ei64_reinterpret_f64 e

instance to_char TWord where to_char e = cast_expr (Eand (Ei64_const 255) e)

instance to_int  TWord where to_int  e = cast_expr e

instance to_real TWord where to_real e = Ef64_reinterpret_i64 (cast_expr e)

instance to_word_ptr TWord     where to_word_ptr  e = cast_expr e
instance to_word_ptr (TPtr t)  where to_word_ptr  e = cast_expr e
instance to_char_ptr TWord     where to_char_ptr  e = cast_expr e
instance to_char_ptr (TPtr t)  where to_char_ptr  e = cast_expr e
instance to_short_ptr TWord    where to_short_ptr e = cast_expr e
instance to_short_ptr (TPtr t) where to_short_ptr e = cast_expr e

instance + (Expr t) where + a b = Eadd a b
instance - (Expr t) where - a b = Esub a b
instance * (Expr t) where * a b = Emul a b
instance / (Expr t) where / a b = Ediv_s a b
438
instance ^ (Expr TReal) where ^ a b = ECall "clean_powR" (a -- b -- ELNil)
439 440 441 442 443 444 445 446 447 448 449

(%.)  infixl 6 :: !(Expr TInt) !(Expr TInt) -> Expr TInt
(%.) a b = Erem_s a b

(==.) infix 4 :: !(Expr a) !(Expr a) -> Expr TWord
(==.) a b = Eeq a b

(<>.) infix  4 :: !(Expr a) !(Expr a) -> Expr TWord
(<>.) a b = Ene a b

(<.) infix 4 :: !(Expr a) !(Expr a) -> Expr TWord
450
(<.) a b = Elt_s a b
451 452

(>.) infix 4 :: !(Expr a) !(Expr a) -> Expr TWord
453
(>.) a b = Egt_s a b
454 455

(<=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TWord
456
(<=.) a b = Ele_s a b
457 458

(>=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TWord
459
(>=.) a b = Ege_s a b
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476

(&&.) infixr 3 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(&&.) a b = Eand a b

notB :: !(Expr TWord) -> Expr TWord
notB a = Eeqz a

(&.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(&.) a b = Eand a b

(|.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(|.) a b = Eor a b

(<<.) infix 7 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) a b = Eshl a b

(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
477
(>>.) a b = Eshr_s a b
478 479 480 481 482

xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
xorI a b = Exor a b

~. :: !(Expr TWord) -> Expr TWord
Camil Staps's avatar
Camil Staps committed
483
~. a = Exor (Elit "i64" "(i64.const 0xffffffffffffffff)") a // must be literal to avoid Clean integer overflow
484 485 486 487 488

absR :: !(Expr TReal) -> Expr TReal
absR e = Eabs e

acosR :: !(Expr TReal) -> Expr TReal
489
acosR e = ECall "clean_acosR" (e -- ELNil)
490 491

asinR :: !(Expr TReal) -> Expr TReal
492
asinR e = ECall "clean_asinR" (e -- ELNil)
493 494

atanR :: !(Expr TReal) -> Expr TReal
495
atanR e = ECall "clean_atanR" (e -- ELNil)
496 497

cosR :: !(Expr TReal) -> Expr TReal
498
cosR e = ECall "clean_cosR" (e -- ELNil)
499 500 501 502 503

entierR :: !(Expr TReal) -> Expr TInt
entierR e = Ei64_trunc_f64_s (Efloor e)

expR :: !(Expr TReal) -> Expr TReal
504
expR e = ECall "clean_expR" (e -- ELNil)
505 506

lnR :: !(Expr TReal) -> Expr TReal
507
lnR e = ECall "clean_lnR" (e -- ELNil)
508 509

log10R :: !(Expr TReal) -> Expr TReal
510
log10R e = ECall "clean_log10R" (e -- ELNil)
511 512 513 514 515

negR :: !(Expr TReal) -> Expr TReal
negR e = Eneg e

sinR :: !(Expr TReal) -> Expr TReal
516
sinR e = ECall "clean_sinR" (e -- ELNil)
517 518 519 520 521

sqrtR :: !(Expr TReal) -> Expr TReal
sqrtR e = Esqrt e

tanR :: !(Expr TReal) -> Expr TReal
522
tanR e = ECall "clean_tanR" (e -- ELNil)
523 524 525 526 527 528 529 530 531 532

ItoR :: !(Expr TInt) -> Expr TReal
ItoR e = Ef64_convert_i64_s e

RtoI :: !(Expr TReal) -> Expr TInt
RtoI e = Ei64_trunc_f64_s e

if_i64_or_i32_expr :: !(Expr t) !(Expr t) -> Expr t
if_i64_or_i32_expr a _ = a

533
if_expr :: !(Expr TWord) !(Expr t) !(Expr t) -> Expr t | typename t
534
if_expr c t e = ESelect t e c
535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552

begin_instruction :: !String !Target -> Target
begin_instruction name t = {t & instrs=[name:t.instrs], output=[]}

end_instruction :: !Target -> Target
end_instruction t = append (EBr "abc-loop") t

alias :: !String !(Target -> Target) !Target -> Target
alias name f t = f {t & instrs=[name:t.instrs]}

nop :: !Target -> Target
nop t = t

(:.) infixr 1 :: !(Target -> Target) !(Target -> Target) !Target -> Target
(:.) first then t = then (first t)

class typename a :: !a -> String
instance typename TWord                 where typename _ = "i64"
553 554
instance typename TChar                 where typename _ = "i8"
instance typename TShort                where typename _ = "i16"
555 556 557 558 559 560 561 562
instance typename TInt                  where typename _ = "i64"
instance typename TReal                 where typename _ = "f64"
instance typename (TPtr t) | typename t where typename _ = "i64"

new_local :: !t !(Expr t) !((Expr t) Target -> Target) !Target -> Target | typename t
new_local tp e f t = f var (append (ESet var e) {t & var_counter=t.var_counter+1})
where
	type = typename tp
563
	var = EGlobal type case type.[0] of
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595
		'f' -> "vf"+++toString t.var_counter
		_   -> "vi"+++toString t.var_counter

set :: !(Expr e) !(Expr e) !Target -> Target
set v e t = append (ESet v e) t

instance .= TWord TWord  where .= v e t = set v e t
instance .= TWord TChar  where .= v e t = set v (to_word e) t
instance .= TWord TInt   where .= v e t = set v (to_word e) t
instance .= TWord TShort where .= v e t = set v (to_word e) t
instance .= TChar TChar  where .= v e t = set v e t
instance .= TInt  TInt   where .= v e t = set v e t
instance .= TInt  TWord  where .= v e t = set v (to_int e) t
instance .= (TPtr t) (TPtr u) where .= v e t = set v (cast_expr e) t

add_local :: !(Expr e) !(Expr e) !Target -> Target
add_local v e t = case e of
	Ei64_const 0
		-> t
		-> append (ESet v (Eadd v e)) t

instance += TWord TWord where += v e t = add_local v e t

sub_local :: !(Expr e) !(Expr e) !Target -> Target
sub_local v e t = case e of
	Ei64_const 0
		-> t
		-> append (ESet v (Esub v e)) t

instance -= TWord  TWord  where -= v e t = sub_local v e t
instance -= TShort TShort where -= v e t = sub_local v e t

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624
instance advance_ptr Int
where
	advance_ptr v e t = add_local v (Ei64_const (w*e)) t
	where
		w = case typename (get_type_of_ptr v) of
			"i8"  -> 1
			"i16" -> 2
			"i32" -> 4
			"i64" -> 8

instance advance_ptr  (Expr w)
where
	advance_ptr v e t = add_local v (cast_expr (Emul (Ei64_const w) e)) t
	where
		w = case typename (get_type_of_ptr v) of
			"i8"  -> 1
			"i16" -> 2
			"i32" -> 4
			"i64" -> 8

instance rewind_ptr Int
where
	rewind_ptr v e t = sub_local v (Ei64_const (w*e)) t
	where
		w = case typename (get_type_of_ptr v) of
			"i8"  -> 1
			"i16" -> 2
			"i32" -> 4
			"i64" -> 8
625

626 627 628 629 630 631 632 633 634
instance rewind_ptr  (Expr w)
where
	rewind_ptr v e t = sub_local v (cast_expr (Emul (Ei64_const w) e)) t
	where
		w = case typename (get_type_of_ptr v) of
			"i8"  -> 1
			"i16" -> 2
			"i32" -> 4
			"i64" -> 8
635

636 637 638 639 640 641 642 643 644 645 646 647 648 649
instance @ Int
where
	(@) arr i = EDeref load_width store_width arr (Ei64_const i)
	where
		(load_width,store_width) = load_and_store_widths arr

instance @ (Expr t)
where
	(@) arr i = EDeref load_width store_width arr (cast_expr i)
	where
		(load_width,store_width) = load_and_store_widths arr

instance @? Int
where
650
	(@?) arr i = ERef load_width store_width arr (Ei64_const i)
651 652
	where
		(load_width,store_width) = load_and_store_widths arr
653

654 655
instance @? (Expr t)
where
656
	(@?) arr i = ERef load_width store_width arr (cast_expr i)
657 658 659 660
	where
		(load_width,store_width) = load_and_store_widths arr

load_and_store_widths :: !(Expr (TPtr t)) -> (!String, !String) | typename t
661 662
load_and_store_widths e = case typename (get_type_of_ptr e) of
	"i8"  -> ("8_u","8")
663
	"i16" -> ("16_s","16")
664 665 666 667 668 669 670
	"i64" -> ("","")

get_type_of_ptr :: !(Expr (TPtr t)) -> t
get_type_of_ptr _ = code {
	pop_a 1
	buildI 123 | non-aborting undef
}
671 672

begin_block :: !Target -> Target
673
begin_block t = append "(block" t
674 675

end_block :: !Target -> Target
676
end_block t = append ")" t
677 678

while_do :: !(Expr TWord) !(Target -> Target) !Target -> Target
679 680 681 682 683 684 685 686
while_do c f t =
	append EEnd
	(append EEnd
	(append "(br 0)"
	(f
	(append (EBr_if 1 (Eeqz c))
	(append "(loop"
	(append "(block" t))))))
687 688

break :: !Target -> Target
689
break t = append "(br 1)" t
690

691
if_then_else ::
692 693 694 695
	!(Expr TWord) !(Target -> Target)
	![(Expr TWord, Target -> Target)]
	!(Maybe (Target -> Target))
	!Target -> Target
696 697 698 699 700 701 702 703 704 705 706 707 708 709
if_then_else c then elifs else t =
	iter (2*length elifs) (append EEnd)
	(append EEnd
	(mbelse
	(foldl elif
		(append EEnd (then (append EThen
			(append (EIf c) t))))
		elifs)))
where
	mbelse t = case else of
		Nothing -> t
		Just e  -> append EEnd (e (append EElse t))

	elif t (cond, block) = append EEnd (block (append EThen (append (EIf cond) (append EElse t))))
710 711

if_break_else :: !(Expr TWord) !(Target -> Target) !Target -> Target
712
if_break_else c else t = else (append (EBr_if 0 c) t)
713 714 715 716 717 718 719 720 721 722 723

instance ensure_hp Int
where
	ensure_hp i t = ensure_hp ie t
	where
		ie :: Expr TWord
		ie = Ei64_const i

instance ensure_hp (Expr TWord)
where
	ensure_hp i t = if_then_else
724 725
		(Elt_s Hp_free (Ei64_const 0))
		(Hp_free += i :. append (EBr "abc-gc"))
726 727
		[]
		Nothing
728
		(append (ESet Hp_free (Esub Hp_free i)) t)
729 730

A :: Expr (TPtr TWord)
731
A = EGlobal "i64" "asp"
732 733

B :: Expr (TPtr TWord)
734
B = EGlobal "i64" "bsp"
735 736

Pc :: Expr (TPtr TWord)
737
Pc = EGlobal "i64" "pc"
738 739

Hp :: Expr (TPtr TWord)
740 741 742 743
Hp = EGlobal "i64" "hp"

Hp_free :: Expr TWord
Hp_free = EGlobal "i64" "hp_free"
744 745

BOOL_ptr :: Expr TWord
746
BOOL_ptr = Ei64_const (11*8)
747 748

CHAR_ptr :: Expr TWord
749
CHAR_ptr = Ei64_const (16*8)
750 751

INT_ptr :: Expr TWord
752
INT_ptr = Ei64_const (26*8)
753 754

REAL_ptr :: Expr TWord
755
REAL_ptr = Ei64_const (21*8)
756 757

ARRAY__ptr :: Expr TWord
758
ARRAY__ptr = Ei64_const (1*8)
759 760

STRING__ptr :: Expr TWord
761
STRING__ptr = Ei64_const (6*8)
762 763

jmp_ap_ptr :: !Int -> Expr TWord
764
jmp_ap_ptr i = Ei64_const ((99+i)*8)
765 766

cycle_ptr :: Expr TWord
767
cycle_ptr = Ei64_const (131*8)
768 769

indirection_ptr :: Expr TWord
770
indirection_ptr = Ei64_const ((131+1+5)*8)
771 772

dNil_ptr :: Expr TWord
773
dNil_ptr = Ei64_const ((141+1)*8)
774 775

small_integer :: !(Expr TInt) -> Expr TWord
776 777 778 779
small_integer i = Eadd (Ei64_const (8*31)) (Eshl (cast_expr i) (Ei64_const 4))

static_character :: !(Expr TChar) -> Expr TWord
static_character c = Eadd (Ei64_const (8*147)) (Eshl (cast_expr c) (Ei64_const 4))
780 781

caf_list :: Expr (TPtr (TPtr TWord))
782 783 784
caf_list = Ei64_const (97*8)

C = EGlobal "i64" "csp"
785 786

push_c :: !(Expr TWord) !Target -> Target
787 788
push_c v t = append (ESet C (Eadd C (Ei64_const 8)))
	(append (Estore32 C v) t)
789

790 791 792
pop_pc_from_c :: !Target -> Target
pop_pc_from_c t = append (ESet Pc (Eload32 C))
	(append (ESet C (Esub C (Ei64_const 8))) t)
793 794 795 796 797 798 799 800 801 802 803 804 805 806

memcpy :: !(Expr (TPtr a)) !(Expr (TPtr b)) !(Expr TWord) !Target -> Target
memcpy d s n t = append (ECall "clean_memcpy" (d -- s -- n -- ELNil)) t

strncmp :: !(Expr (TPtr TChar)) !(Expr (TPtr TChar)) !(Expr TWord) -> Expr TInt
strncmp s1 s2 n = ECall "clean_strncmp" (s1 -- s2 -- n -- ELNil)

putchar :: !(Expr TChar) !Target -> Target
putchar c t = append (ECall "clean_putchar" (c -- ELNil)) t

print_bool :: !(Expr TWord) !Target -> Target
print_bool c t = append (ECall "clean_print_bool" (c -- ELNil)) t

print_char :: !Bool !(Expr TChar) !Target -> Target
807
print_char quotes c t = append (ECall (if quotes "clean_print_char" "clean_putchar") (c -- ELNil)) t
808 809

print_int :: !(Expr TInt) !Target -> Target
810 811 812 813
print_int c t = append (ECall "clean_print_int" (high -- low -- ELNil)) t
where
	high = Eshr_u c (Ei64_const 32)
	low = Eand c (Ei64_const 0xffffffff)
814 815 816

print_real :: !(Expr TReal) !Target -> Target
print_real c t = append (ECall "clean_print_real" (c -- ELNil)) t