target.icl 20.5 KB
Newer Older
1 2 3 4 5
implementation module target

import StdEnv
import StdMaybe
import interpretergen
6
import wasm
7 8

instance wasm_type TWord    where wasm_type _ = I64
9
instance wasm_type TPtrOffset   where wasm_type _ = I32
10 11 12 13 14 15 16 17 18 19 20
instance wasm_type TBool    where wasm_type _ = I32
instance wasm_type TChar    where wasm_type _ = I8
instance wasm_type TShort   where wasm_type _ = I16
instance wasm_type TInt     where wasm_type _ = I64
instance wasm_type TReal    where wasm_type _ = F64
instance wasm_type (TPtr t) where wasm_type _ = I32

instance wasm_literal String
where
	wasm_repr s = s
	is_zero s = abort "is_zero String\n"
21

22 23 24 25 26
:: TempVars =
	{ tv_i32 :: !Int
	, tv_i64 :: !Int
	, tv_f64 :: !Int
	}
27

28 29 30 31 32
:: Target =
	{ stmts     :: ![Ex]
	, instrs    :: ![String]
	, temp_vars :: !TempVars
	}
33

34 35 36 37 38 39
start :: Target
start =
	{ instrs    = []
	, stmts     = []
	, temp_vars = {tv_i32=0,tv_i64=0,tv_f64=0}
	}
40

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
append e t :== {t & stmts=[e:t.stmts]}

new_temp_var :: !Type !Target -> (!Variable, !Target)
new_temp_var tp t
# tp = case tp of
	I8  -> I64
	I16 -> I64
	tp  -> tp
# var = case tp of
	I32 -> i32_temp_vars.[t.temp_vars.tv_i32]
	I64 -> i64_temp_vars.[t.temp_vars.tv_i64]
	F64 -> f64_temp_vars.[t.temp_vars.tv_f64]
# t = case tp of
	I32 -> {t & temp_vars.tv_i32=t.temp_vars.tv_i32+1}
	I64 -> {t & temp_vars.tv_i64=t.temp_vars.tv_i64+1}
	F64 -> {t & temp_vars.tv_f64=t.temp_vars.tv_f64+1}
= (Local var,t)

i32_temp_vars =: {#{#'v','w',i} \\ i <- ['0'..'9']}
i64_temp_vars =: {#{#'v','q',i} \\ i <- ['0'..'9']}
f64_temp_vars =: {#{#'v','d',i} \\ i <- ['0'..'0']}
Camil Staps's avatar
Camil Staps committed
62

63
:: Expr t :== Ex
64

65 66
cast_expr :: !Ex -> Ex
cast_expr e = e
67 68 69 70

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

71 72 73
rt_vars :: [String]
rt_vars =: ["pc","asp","bsp","csp","hp","hp-size","hp-free"]

74 75 76
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 =
77 78
	header ++
	reverse [block_start i \\ i <- is_with_illegal_block] ++
79
	switch ++
80 81
	flatten [block_body i \\ i <- is_with_illegal_block] ++
	footer
82
where
83 84 85
	is_with_illegal_block = is ++ [end_instruction (instr_unimplemented (begin_instruction "illegal" start))]

	header =
86 87
		[ "(module"
		, "(import \"clean\" \"memory\" (memory 1))"
88

89
		, "(func $clean_memcpy (import \"clean\" \"memcpy\") (param i32 i32 i32))"
90 91
		, "(func $clean_strncmp (import \"clean\" \"strncmp\") (param i32 i32 i32) (result i32))"
		, "(func $clean_putchar (import \"clean\" \"putchar\") (param i32))"
92
		, "(func $clean_print_int (import \"clean\" \"print_int\") (param i32 i32))"
93
		, "(func $clean_print_bool (import \"clean\" \"print_bool\") (param i32))"
94 95
		, "(func $clean_print_char (import \"clean\" \"print_char\") (param i32))"
		, "(func $clean_print_real (import \"clean\" \"print_real\") (param f64))"
96 97 98 99 100 101 102 103 104 105
		, "(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))"
106
		, "(func $clean_RtoAC_words_needed (import \"clean\" \"RtoAC_words_needed\") (param f64) (result i32))"
107
		, "(func $clean_RtoAC (import \"clean\" \"RtoAC\") (param i32 f64) (result i32))"
108
		, if debug_instructions "(func $clean_debug_instr (import \"clean\" \"debug_instr\") (param i32 i32))" ""
109
		// For illegal instructions, first the handler is called with arguments (pc,instr,asp,bsp,csp,hp,hp-free).
110 111
		// If the result is zero, clean_illegal_instr is called with (pc,instr) and interpretation stops.
		// Otherwise, the result is taken as the new program counter.
112
		, "(func $clean_handle_illegal_instr (import \"clean\" \"handle_illegal_instr\") (param i32 i32 i32 i32 i32 i32 i32) (result i32))"
113
		, "(func $clean_illegal_instr (import \"clean\" \"illegal_instr\") (param i32 i32))"
114
		, "(func $clean_out_of_memory (import \"clean\" \"out_of_memory\"))"
115
		, "(func $clean_gc (import \"clean\" \"gc\") (param i32))"
116
		, "(func $clean_halt (import \"clean\" \"halt\") (param i32 i32 i32))"
117
		] ++
118 119 120 121 122 123 124 125 126 127 128 129 130

		[ "(global $g-"+++v+++" (mut i32) (i32.const 0))" \\ v <- rt_vars ] ++
		[ "(func (export \"get_"+++{if (c=='-') '_' c \\ c <-: v}+++"\") (result i32) (global.get $g-"+++v+++"))" \\ v <- rt_vars ] ++
		[ "(func (export \"set_"+++{if (c=='-') '_' c \\ c <-: v}+++"\") (param i32) (global.set $g-"+++v+++" (local.get 0)))" \\ v <- rt_vars ] ++

		[ "(func (export \"interpret\") (result i32)" ] ++
		[ "(local $"+++v+++" i32)" \\ v <- rt_vars ] ++
		[ "(local $vw"+++toString i+++" i32)" \\ i <- [0..maxList [i.temp_vars.tv_i32 \\ i <- is]] ] ++
		[ "(local $vq"+++toString i+++" i64)" \\ i <- [0..maxList [i.temp_vars.tv_i64 \\ i <- is]] ] ++
		[ "(local $vd"+++toString i+++" f64)" \\ i <- [0..maxList [i.temp_vars.tv_f64 \\ i <- is]] ] ++
		[ "(local.set $"+++v+++" (global.get $g-"+++v+++"))" \\ v <- rt_vars ] ++

		[ "(loop $abc-loop"
131 132
		, "(block $abc-gc"
		]
133
	footer =
134
		[ ")" // block abc-gc
135 136
		, "(call $clean_gc (local.get $asp))"
		, "(if (i32.le_s (global.get $g-hp-free) (local.get $hp-free))"
137
		, "\t(then (call $clean_out_of_memory) (unreachable)))"
138 139
		, "(local.set $hp (global.get $g-hp))"
		, "(local.set $hp-free (global.get $g-hp-free))"
140
		, "(br $abc-loop)"
141 142 143 144 145 146 147
		, ")" // loop abc-loop
		, "(unreachable)"
		, ")" // func
		, ")" // module
		]

	block_start t = "(block $instr_"+++hd t.instrs
148
	block_body t = [")":head ++ [toString s \\ s <- reverse t.stmts]]
149 150 151 152
	where
		head = reverse [";; "+++i \\ i <- t.instrs]

	switch =
153
		[ if debug_instructions
154
			"\t(call $clean_debug_instr (local.get $pc) (i32.load (local.get $pc)))"
155
			""
156 157
		, "\t(br_table " +++
			foldr (+++) "" [find_label i is \\ i <- instrs_order] +++
158
			"$instr_illegal (i32.load (local.get $pc)))"
159 160 161 162 163 164
		]
	where
		find_label i [t:ts]
		| isMember i t.instrs
			= "$instr_"+++hd t.instrs+++" "
			= find_label i ts
165
		find_label _ [] = "$instr_illegal "
166 167

instr_unimplemented :: !Target -> Target
168
instr_unimplemented t = (
169 170 171 172 173 174 175 176 177
	new_local (TPtr TWord) (Ecall "clean_handle_illegal_instr"
		[ Eget (Local "pc")
		, Eload I32 I32 DontCare 0 (Eget (Local "pc"))
		, Eget (Local "asp")
		, Eget (Local "bsp")
		, Eget (Local "csp")
		, Eget (Local "hp")
		, Eget (Local "hp-free")
		]) \res -> let new_pc = fix_type (TPtr TWord) res in
178
	if_then_else (to_word new_pc ==. lit_word 0) (
179 180 181 182
		append (Ecall "clean_illegal_instr"
			[ Eget (Local "pc")
			, Eload I32 I32 DontCare 0 (Eget (Local "pc"))
			]) :.
183 184 185 186 187 188 189
		append (Ereturn (Econst I32 1))
	) [] Nothing :.
	Pc .= new_pc
	) t
where
	fix_type :: !t !(Expr t) -> Expr t
	fix_type _ e = e
190 191

instr_halt :: !Target -> Target
192
instr_halt t = (
193
	append (Ecall "clean_halt" [Eget (Local "pc"), Eget (Local "hp-free"), Eget (Local "hp-size")]) :.
194 195
	append (Ereturn (Econst I32 0))
	) t
196 197

instr_divLU :: !Target -> Target
198
instr_divLU t = instr_unimplemented t // TODO
199 200

instr_mulUUL :: !Target -> Target
201
instr_mulUUL t = instr_unimplemented t // TODO
202

203
instr_RtoAC :: !Target -> Target
204 205
instr_RtoAC t = (
	new_local TReal (to_real (B @ 0)) \r ->
206
	new_local TPtrOffset (Ecall "clean_RtoAC_words_needed" [r]) \lw ->
207
	//ensure_hp (lw ::: TPtrOffset) :. // TODO
208
	A @ 1 .= to_word Hp :.
209
	Hp .= (Ecall "clean_RtoAC" [Hp,r] ::: TPtr TWord) :.
210 211 212 213 214 215 216
	advance_ptr Pc 1 :.
	advance_ptr A 1 :.
	advance_ptr B 1
	) t
where
	(:::) :: !(Expr t) t -> Expr t
	(:::) e _ = e
217

218
lit_word :: !Int -> Expr TWord
219 220
lit_word w = Econst I64 w

221
lit_hword :: !Int -> Expr TPtrOffset
222
lit_hword w = Econst I32 w
223 224

lit_char :: !Char -> Expr TChar
225
lit_char c = Econst I64 c
226 227

lit_short :: !Int -> Expr TShort
228
lit_short s = Econst I64 s
229 230

lit_int :: !Int -> Expr TInt
231
lit_int i = Econst I64 i
232

233
instance to_word TBool    where to_word  c = Eextend I64 I32 c
234
instance to_word TPtrOffset   where to_word  c = Eextend I64 I32 c
235 236 237 238 239
instance to_word TChar    where to_word  c = cast_expr c
instance to_word TInt     where to_word  i = cast_expr i
instance to_word TShort   where to_word  s = cast_expr s
instance to_word (TPtr t) where to_word  p = Eextend I64 I32 p
instance to_word TReal    where to_word  r = Ereinterpret I64 F64 r
240

241
instance to_bool  TWord   where to_bool  w = Ewrap I32 I64 w
242

243
instance to_char TWord    where to_char  w = cast_expr w
244

245
instance to_int TWord     where to_int   w = cast_expr w
246

247
instance to_real TWord    where to_real  w = Ereinterpret F64 I64 w
248

249 250 251 252 253 254
instance to_word_ptr  TWord    where to_word_ptr  w = Ewrap I32 I64 w
instance to_word_ptr  (TPtr t) where to_word_ptr  p = cast_expr p
instance to_char_ptr  TWord    where to_char_ptr  w = Ewrap I32 I64 w
instance to_char_ptr  (TPtr t) where to_char_ptr  p = cast_expr p
instance to_short_ptr TWord    where to_short_ptr w = Ewrap I32 I64 w
instance to_short_ptr (TPtr t) where to_short_ptr p = cast_expr p
255

256 257 258 259
instance to_ptr_offset TWord      where to_ptr_offset w = Ewrap I32 I64 w
instance to_ptr_offset TPtrOffset where to_ptr_offset w = w
instance to_ptr_offset TShort     where to_ptr_offset s = Ewrap I32 I64 s

260 261 262 263
instance + (Expr t)     where + a b = Eadd (type2 a b) a b
instance - (Expr t)     where - a b = Esub (type2 a b) a b
instance * (Expr t)     where * a b = Emul (type2 a b) a b
instance / (Expr t)     where / a b = Ediv (type2 a b) Signed a b
264
instance ^ (Expr TReal) where ^ a b = Ecall "clean_powR" [a,b]
265 266 267

(%.)  infixl 6 :: !(Expr TInt) !(Expr TInt) -> Expr TInt
(%.) a b = Erem (type2 a b) Signed a b
268

269 270
(==.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(==.) a b = Eeq (type2 a b) a b
271

272 273
(<>.) infix  4 :: !(Expr a) !(Expr a) -> Expr TBool
(<>.) a b = Ene (type2 a b) a b
274

275 276
(<.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<.) a b = Elt (type2 a b) Signed a b
277

278 279
(>.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>.) a b = Egt (type2 a b) Signed a b
280

281 282
(<=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<=.) a b = Ele (type2 a b) Signed a b
283

284 285
(>=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>=.) a b = Ege (type2 a b) Signed a b
286

287
(&&.) infixr 3 :: !(Expr TBool) !(Expr TBool) -> Expr TBool
288
(&&.) a b = Eand (type2 a b) a b
289 290

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

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

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

(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
300
(>>.) a b = Eshr (type2 a b) Signed a b
301 302

xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
303
xorI a b = Exor (type2 a b) a b
304 305

~. :: !(Expr TWord) -> Expr TWord
306
~. a = Exor I64 (Econst I64 "0xffffffffffffffff") a // string literal to avoid Clean integer overflow
307 308

absR :: !(Expr TReal) -> Expr TReal
309
absR r = Eabs (type r) r
310 311

acosR :: !(Expr TReal) -> Expr TReal
312
acosR r = Ecall "clean_acosR" [r]
313 314

asinR :: !(Expr TReal) -> Expr TReal
315
asinR r = Ecall "clean_asinR" [r]
316 317

atanR :: !(Expr TReal) -> Expr TReal
318
atanR r = Ecall "clean_atanR" [r]
319 320

cosR :: !(Expr TReal) -> Expr TReal
321
cosR r = Ecall "clean_cosR" [r]
322 323

entierR :: !(Expr TReal) -> Expr TInt
324
entierR r = Etrunc I64 F64 (Efloor F64 r)
325 326

expR :: !(Expr TReal) -> Expr TReal
327
expR r = Ecall "clean_expR" [r]
328 329

lnR :: !(Expr TReal) -> Expr TReal
330
lnR r = Ecall "clean_lnR" [r]
331 332

log10R :: !(Expr TReal) -> Expr TReal
333
log10R r = Ecall "clean_log10R" [r]
334 335

negR :: !(Expr TReal) -> Expr TReal
336
negR r = Eneg (type r) r
337 338

sinR :: !(Expr TReal) -> Expr TReal
339
sinR r = Ecall "clean_sinR" [r]
340 341

sqrtR :: !(Expr TReal) -> Expr TReal
342
sqrtR r = Esqrt (type r) r
343 344

tanR :: !(Expr TReal) -> Expr TReal
345
tanR r = Ecall "clean_tanR" [r]
346

347 348
ItoR :: !(Expr TInt)  -> Expr TReal
ItoR i = Econvert F64 I64 i
349 350

RtoI :: !(Expr TReal) -> Expr TInt
351
RtoI i = Etrunc I64 F64 i
352

353 354 355
if_i64_or_i32 :: !(Target -> Target) !(Target -> Target) !Target -> Target
if_i64_or_i32 i64 _ t = i64 t

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

359 360
if_expr :: !(Expr TBool) !(Expr t) !(Expr t) -> Expr t
if_expr c t e = Eselect t e c
361 362

begin_instruction :: !String !Target -> Target
363
begin_instruction name t = {t & instrs=[name:t.instrs], stmts=[]}
364 365

end_instruction :: !Target -> Target
366
end_instruction t = append (Ebr "abc-loop") t
367 368 369 370 371 372 373 374 375 376

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)

377 378 379 380
new_local :: !t !(Expr t) !((Expr t) Target -> Target) !Target -> Target | wasm_type t
new_local tp e f t
# (var,t) = new_temp_var (wasm_type tp) t
= f (Ivar var) (append (Eset var e) t)
381

382 383
set :: !Ex !Ex !Target -> Target
set var e t = append expr t
384
where
385 386 387 388 389 390 391
	expr = case var of
		Ivar var
			-> Eset var e
		Iref vartype loadtype offset addr
			-> Estore vartype loadtype offset addr e

instance .= TWord  TWord  where .= v e t = set v e t
392
instance .= TWord  TPtrOffset where .= v e t = set v (to_word e) t
393 394 395 396 397
instance .= TWord  TBool  where .= v e t = set v (to_word 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

398
instance .= TPtrOffset TPtrOffset where .= v e t = set v e t
399

400
instance .= TChar  TChar  where .= v e t = set v e t
401

402 403 404 405 406 407 408 409
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 e t

var_add :: !Ex !Ex !Target -> Target
var_add v e t = case e of
	Econst _ v | is_zero v
410
		-> t
411 412 413 414 415 416 417 418 419
	_
		-> case v of
			Ivar v
				-> append (Eset v (Eadd (type2 (Eget v) e) (Eget v) e)) t
			Iref localtype storetype offset addr
				-> append (Estore localtype storetype offset addr
					(Eadd (type2 ld e) ld e)) t
				with
					ld = Eload localtype storetype Signed offset addr
420

421 422 423 424 425 426 427 428 429 430 431 432 433 434 435
var_sub :: !Ex !Ex !Target -> Target
var_sub v e t = case e of
	Econst _ v | is_zero v
		-> t
	_
		-> case v of
			Ivar v
				-> append (Eset v (Esub (type2 (Eget v) e) (Eget v) e)) t
			Iref localtype storetype offset addr
				-> append (Estore localtype storetype offset addr
					(Esub (type2 ld e) ld e)) t
				with
					ld = Eload localtype storetype Signed offset addr

instance += TWord  TWord  where += var val t = var_add var val t
436
instance += TPtrOffset TPtrOffset where += var val t = var_add var val t
437 438

instance -= TWord  TWord  where -= var val t = var_sub var val t
439
instance -= TPtrOffset TPtrOffset where -= var val t = var_sub var val t
440
instance -= TShort TShort where -= var val t = var_sub var val t
441

442 443
instance advance_ptr Int
where
444
	advance_ptr v e t = var_add v (Econst I32 (w*e)) t
445
	where
446
		w = type_width (wasm_type (get_type_of_ptr v))
447

448
instance advance_ptr (Expr TPtrOffset)
449
where
450
	advance_ptr v e t = var_add v (Eshl I32 e (Econst I32 s)) t
451
	where
452
		s = type_width_shift (wasm_type (get_type_of_ptr v))
453 454 455

instance rewind_ptr Int
where
456
	rewind_ptr v e t = var_sub v (Econst I32 (w*e)) t
457
	where
458
		w = type_width (wasm_type (get_type_of_ptr v))
459

460
instance rewind_ptr (Expr TPtrOffset)
461
where
462
	rewind_ptr v e t = var_sub v (Eshl I32 e (Econst I32 s)) t
463
	where
464 465 466 467 468 469 470
		s = type_width_shift (wasm_type (get_type_of_ptr v))

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

472 473
instance @ Int
where
474 475 476
	@ p i
	| i >= 0 = Iref loc_type store_type idx p
	| otherwise = Iref loc_type store_type 0 (Esub I32 p (Econst I32 idx))
477
	where
478 479 480 481 482 483 484
		store_type = wasm_type (get_type_of_ptr p)
		loc_type = case store_type of
			I8  -> I64
			I16 -> I64
			t   -> t
		s = type_width_shift (wasm_type (get_type_of_ptr p))
		idx = abs i << s
485 486 487

instance @ (Expr t)
where
488
	@ p e = Iref loc_type store_type 0 (p @? e)
489
	where
490 491 492 493 494
		store_type = wasm_type (get_type_of_ptr p)
		loc_type = case store_type of
			I8  -> I64
			I16 -> I64
			t   -> t
495 496 497

instance @? Int
where
498
	@? p i = if (i>=0) Eadd Esub I32 p (Econst I32 (abs i << s))
499
	where
500
		s = type_width_shift (wasm_type (get_type_of_ptr p))
501

502 503
instance @? (Expr t)
where
504
	@? p e
505
	# e = if (type e==I64) (Ewrap I32 I64 e) e
506 507
	| sft == 0  = Eadd I32 p e
	| otherwise = Eadd I32 p (Eshl I32 e (Econst I32 sft))
508
	where
509 510
		ptr_type = wasm_type (get_type_of_ptr p)
		sft = type_width_shift ptr_type
511

512
begin_block :: !Target -> Target
513
begin_block t = append Eblock t
514 515

end_block :: !Target -> Target
516 517 518 519 520 521 522 523 524 525 526 527
end_block t = append Eend t

while_do :: !(Expr TBool) !(Target -> Target) !Target -> Target
while_do c f t = (
	append Eblock :.
		append Eloop :.
			append (Ebr_if 1 (Eeqz I32 c)) :.
			f :.
			append (Ebr_local 0) :.
		append Eend :.
	append Eend
	) t
528 529

break :: !Target -> Target
530
break t = append (Ebr_local 1) t
531

532
if_then_else ::
533 534
	!(Expr TBool) !(Target -> Target)
	![(Expr TBool, Target -> Target)]
535 536
	!(Maybe (Target -> Target))
	!Target -> Target
537
if_then_else c then elifs else t =
538 539
	iter (2*length elifs) (append Eend)
	(append Eend
540 541
	(mbelse
	(foldl elif
542 543
		(append Eend (then (append Ethen
			(append (Eif c) t))))
544 545 546 547
		elifs)))
where
	mbelse t = case else of
		Nothing -> t
548
		Just e  -> append Eend (e (append Eelse t))
549

550
	elif t (cond, block) = append Eend (block (append Ethen (append (Eif cond) (append Eelse t))))
551

552 553
if_break_else :: !(Expr TBool) !(Target -> Target) !Target -> Target
if_break_else c else t = else (append (Ebr_if 0 c) t)
554

555
instance ensure_hp (Expr t) | to_ptr_offset t
556
where
557 558
	ensure_hp i t = if_then_else
		(Elt I32 Signed Hp_free (Econst I32 0))
559
		(Hp_free += to_ptr_offset i :. append (Ebr "abc-gc"))
560 561
		[]
		Nothing
562
		((Hp_free .= Hp_free - to_ptr_offset i) t)
563

564
instance ensure_hp Int
565 566
where
	ensure_hp i t = if_then_else
567 568
		(Elt I32 Signed Hp_free (Econst I32 0))
		(Hp_free += ie :. append (Ebr "abc-gc"))
569 570
		[]
		Nothing
571 572
		((Hp_free .= Hp_free - ie) t)
	where
573
		ie :: Expr TPtrOffset
574
		ie = Econst I32 i
575 576

A :: Expr (TPtr TWord)
577
A = Ivar (Local "asp")
578 579

B :: Expr (TPtr TWord)
580
B = Ivar (Local "bsp")
581 582

Pc :: Expr (TPtr TWord)
583
Pc = Ivar (Local "pc")
584 585

Hp :: Expr (TPtr TWord)
586
Hp = Ivar (Local "hp")
587

588
Hp_free :: Expr TPtrOffset
589
Hp_free = Ivar (Local "hp-free")
590 591

BOOL_ptr :: Expr TWord
592
BOOL_ptr = Econst I64 (11*8)
593 594

CHAR_ptr :: Expr TWord
595
CHAR_ptr = Econst I64 (16*8)
596 597

INT_ptr :: Expr TWord
598
INT_ptr = Econst I64 (26*8)
599 600

REAL_ptr :: Expr TWord
601
REAL_ptr = Econst I64 (21*8)
602 603

ARRAY__ptr :: Expr TWord
604
ARRAY__ptr = Econst I64 (1*8)
605 606

STRING__ptr :: Expr TWord
607
STRING__ptr = Econst I64 (6*8)
608

609 610
jmp_ap_ptr :: !Int -> Expr (TPtr TWord)
jmp_ap_ptr i = Econst I32 ((99+i)*8)
611 612

cycle_ptr :: Expr TWord
613
cycle_ptr = Econst I64 (131*8)
614 615

indirection_ptr :: Expr TWord
616
indirection_ptr = Econst I64 ((131+1+5)*8)
617 618

dNil_ptr :: Expr TWord
619
dNil_ptr = Econst I64 ((141+1)*8)
620 621

small_integer :: !(Expr TInt) -> Expr TWord
622
small_integer i = Eadd I64 (Econst I64 (8*31)) (Eshl I64 i (Econst I64 4))
623 624

static_character :: !(Expr TChar) -> Expr TWord
625
static_character c = Eadd I64 (Econst I64 (8*147)) (Eshl I64 c (Econst I64 4))
626

Camil Staps's avatar
Camil Staps committed
627 628
static_boolean :: !(Expr TWord) -> Expr TWord
static_boolean b = case b of
629 630
	Econst _ i -> if (is_zero i) FALSE TRUE
	b          -> if_expr (Ewrap I32 I64 b) TRUE FALSE
Camil Staps's avatar
Camil Staps committed
631
where
632 633
	TRUE  = Econst I64 (8*668)
	FALSE = Econst I64 (8*666)
Camil Staps's avatar
Camil Staps committed
634

635
caf_list :: Expr (TPtr TWord)
636
caf_list = Econst I32 (97*8)
637

638
C = Local "csp"
639

640 641 642 643 644
push_c :: !(Expr (TPtr TWord)) !Target -> Target
push_c v t = (
	append (Estore I32 I32 0 (Eget C) v) :.
	append (Eset C (Eadd I32 (Eget C) (Econst I32 8)))
	) t
645

646
pop_pc_from_c :: !Target -> Target
647 648 649 650 651 652 653
pop_pc_from_c t = (
	append (Eset C (Eget C - Econst I32 8)) :.
	Pc .= popped_pc
	) t
where
	popped_pc :: Expr (TPtr TWord)
	popped_pc = Eload I32 I32 DontCare 0 (Eget C)
654

655
memcpy :: !(Expr (TPtr a)) !(Expr (TPtr b)) !(Expr TPtrOffset) !Target -> Target
656
memcpy d s n t = append (Ecall "clean_memcpy" [d,cast_expr s,cast_expr n]) t
657

658
strncmp :: !(Expr (TPtr TChar)) !(Expr (TPtr TChar)) !(Expr TPtrOffset) -> Expr TInt
659
strncmp s1 s2 n = Eextend I64 I32 (Ecall "clean_strncmp" [s1,s2,cast_expr n])
660 661

putchar :: !(Expr TChar) !Target -> Target
662
putchar c t = append (Ecall "clean_putchar" [Ewrap I32 I64 c]) t
663 664

print_bool :: !(Expr TWord) !Target -> Target
665
print_bool c t = append (Ecall "clean_print_bool" [Ewrap I32 I64 c]) t
666 667

print_char :: !Bool !(Expr TChar) !Target -> Target
668
print_char quotes c t = append (Ecall (if quotes "clean_print_char" "clean_putchar") [Ewrap I32 I64 c]) t
669 670

print_int :: !(Expr TInt) !Target -> Target
671
print_int c t = append (Ecall "clean_print_int" [high,low]) t
672
where
673 674
	high = Ewrap I32 I64 (Eshr I64 Unsigned c (Econst I64 32))
	low = Ewrap I32 I64 c
675 676

print_real :: !(Expr TReal) !Target -> Target
677
print_real c t = append (Ecall "clean_print_real" [c]) t