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

import StdEnv
import StdMaybe
import interpretergen
6
import wasm
7

8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
/* Use an inner loop for all instructions that do not need the WebAssembly
 * `call` instruction. This is intended for the SpiderMonkey register
 * allocator, which splits live ranges of registers early on around calls. The
 * goal is that the allocator can then properly allocate for the inner loop,
 * and bail out to the outer loop for other instructions. While this does
 * improve the generated code somewhat, it is still (2019-05-18) worse than
 * using globals instead of locals. */
IF_SEPARATE_LOOPS   yes no :== no

/* Use global variables instead of locals for pc, asp, bsp, csp, hp, and
 * hp_free. This is useful because register allocators for WebAssembly tend to
 * hit a bad case for the interpreter in which no registers are assigned for
 * these variables. Using globals then avoids unnecessary loads and spills
 * because globals are 'spilled' directly.
 * NB: should the current setting ever be changed, that means that interfaces
 * elsewhere (interpret.js, iTasks) may need to be changed and/or that
 * instructions that use WebAssembly `call`s may need to write the local status
 * into global variables which can then be updated by the callee. */
IF_GLOBAL_RT_VARS   yes no :== yes

/* This is the same optimization as IF_GLOBAL_RT_VARS, but applies to temporary
 * variables. */
IF_GLOBAL_TEMP_VARS yes no :== yes

rt_var v :== IF_GLOBAL_RT_VARS (Global ("g-"+++v)) (Local v)

instance wasm_type TWord      where wasm_type _ = I64
instance wasm_type TPtrOffset where wasm_type _ = I32
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
42 43 44 45 46

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

48 49 50 51 52
:: TempVars =
	{ tv_i32 :: !Int
	, tv_i64 :: !Int
	, tv_f64 :: !Int
	}
53

54 55 56 57 58
:: Target =
	{ stmts     :: ![Ex]
	, instrs    :: ![String]
	, temp_vars :: !TempVars
	}
59

60 61 62 63 64 65
start :: Target
start =
	{ instrs    = []
	, stmts     = []
	, temp_vars = {tv_i32=0,tv_i64=0,tv_f64=0}
	}
66

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
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}
83
= (IF_GLOBAL_TEMP_VARS Global Local var,t)
84 85 86 87

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
88

89
:: Expr t :== Ex
90

91 92
cast_expr :: !Ex -> Ex
cast_expr e = e
93 94 95 96

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

97 98 99
rt_vars :: [String]
rt_vars =: ["pc","asp","bsp","csp","hp","hp-size","hp-free"]

100 101 102
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 =
103
	header ++
104 105
	IF_SEPARATE_LOOPS
	(
106 107 108
		[ "(loop $abc-loop-outer"
		, "(block $abc-gc-outer" ] ++
		[ "(block $instr_"+++hd i.instrs \\ i <- reverse slow_instrs] ++
109 110 111
		[ "(block $slow-instr"
		, "(loop $abc-loop" ]
	)
Camil Staps's avatar
Camil Staps committed
112 113
		[ "(loop $abc-loop"
		, "(block $abc-gc" ]
114
	++
115 116 117
	[ "(block $instr_"+++hd i.instrs \\ i <- reverse (IF_SEPARATE_LOOPS fast_instrs all_instructions)] ++
	switch True ++
	flatten [block_body {i & stmts=map (optimize fast_opt_options) i.stmts} \\ i <- IF_SEPARATE_LOOPS fast_instrs all_instructions] ++
Camil Staps's avatar
Camil Staps committed
118 119 120 121 122
	IF_SEPARATE_LOOPS
	(
		[ ") ;; abc-loop"
		, ") ;; block slow-instr"
		] ++
123 124
		switch False ++
		flatten [block_body {i & stmts=map (optimize slow_opt_options) i.stmts} \\ i <- slow_instrs] ++
Camil Staps's avatar
Camil Staps committed
125 126 127 128
		gc_block "abc-loop-outer"
	)
		(gc_block "abc-loop")
	++
129
	[ "(unreachable)" ] ++
130
	footer
131
where
132 133 134 135
	all_instructions = sortBy lt_by_may_need_gc
		[end_instruction (instr_unimplemented (begin_instruction "illegal" start)):is]

	lt_by_may_need_gc i1 i2 = not (may_need_gc i1) && may_need_gc i2
136
	where
137
		may_need_gc i = any (any (\e->e=:(Ebr "abc-gc")) o subexpressions) i.stmts
138

139 140 141 142 143
	// only used with IF_SEPARATE_LOOPS
	(slow_instrs,fast_instrs) = partition (\i->any (any (\e->e=:(Ecall _ _) || e=:(Ebr "abc-gc")) o subexpressions) i.stmts) all_instructions
	where
		partition p [x:xs] = let (yes,no) = partition p xs in if (p x) ([x:yes],no) (yes,[x:no])
		partition _ [] = ([],[])
144 145
	fast_opt_options = {rename_labels=[]}
	slow_opt_options = {rename_labels=[("abc-loop","abc-loop-outer"),("abc-gc","abc-gc-outer")]}
146 147

	header =
148 149
		[ "(module"
		, "(import \"clean\" \"memory\" (memory 1))"
150

151
		, "(func $clean_memcpy (import \"clean\" \"memcpy\") (param i32 i32 i32))"
152 153
		, "(func $clean_strncmp (import \"clean\" \"strncmp\") (param i32 i32 i32) (result i32))"
		, "(func $clean_putchar (import \"clean\" \"putchar\") (param i32))"
154
		, "(func $clean_print_int (import \"clean\" \"print_int\") (param i32 i32))"
155
		, "(func $clean_print_bool (import \"clean\" \"print_bool\") (param i32))"
156 157
		, "(func $clean_print_char (import \"clean\" \"print_char\") (param i32))"
		, "(func $clean_print_real (import \"clean\" \"print_real\") (param f64))"
158 159 160 161 162 163 164 165 166 167
		, "(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))"
168
		, "(func $clean_RtoAC_words_needed (import \"clean\" \"RtoAC_words_needed\") (param f64) (result i32))"
169
		, "(func $clean_RtoAC (import \"clean\" \"RtoAC\") (param i32 f64) (result i32))"
170
		, if debug_instructions "(func $clean_debug_instr (import \"clean\" \"debug_instr\") (param i32 i32))" ""
171
		// For illegal instructions, first the handler is called with arguments (pc,instr,asp,bsp,csp,hp,hp-free).
172 173
		// 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.
174
		, "(func $clean_handle_illegal_instr (import \"clean\" \"handle_illegal_instr\") (param i32 i32 i32 i32 i32 i32 i32) (result i32))"
175
		, "(func $clean_illegal_instr (import \"clean\" \"illegal_instr\") (param i32 i32))"
176
		, "(func $clean_out_of_memory (import \"clean\" \"out_of_memory\"))"
177
		, "(func $clean_gc (import \"clean\" \"gc\") (param i32))"
178
		, "(func $clean_halt (import \"clean\" \"halt\") (param i32 i32 i32))"
179
		] ++
180 181 182 183 184

		[ "(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 ] ++

185 186
		[ "(global $g-fast-ap-descriptor (mut i64) (i64.const 0))" ] ++

187 188 189 190
		IF_GLOBAL_TEMP_VARS ["(global $vw"+++toString i+++" (mut i32) (i32.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_i32 \\ i <- is]]] [] ++
		IF_GLOBAL_TEMP_VARS ["(global $vq"+++toString i+++" (mut i64) (i64.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_i64 \\ i <- is]]] [] ++
		IF_GLOBAL_TEMP_VARS ["(global $vd"+++toString i+++" (mut f64) (f64.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_f64 \\ i <- is]]] [] ++

191
		[ "(func (export \"interpret\") (result i32)" ] ++
192 193 194

		IF_GLOBAL_TEMP_VARS [] ["(local $vw"+++toString i+++" i32)" \\ i <- [0..maxList [i.temp_vars.tv_i32 \\ i <- is]]] ++
		IF_GLOBAL_TEMP_VARS [] ["(local $vq"+++toString i+++" i64)" \\ i <- [0..maxList [i.temp_vars.tv_i64 \\ i <- is]]] ++
195 196 197 198
		IF_GLOBAL_TEMP_VARS [] ["(local $vd"+++toString i+++" f64)" \\ i <- [0..maxList [i.temp_vars.tv_f64 \\ i <- is]]] ++

		IF_GLOBAL_RT_VARS [] ["(local $"+++v+++" i32)" \\ v <- rt_vars] ++
		IF_GLOBAL_RT_VARS [] ["(local.set $"+++v+++" (global.get $g-"+++v+++"))" \\ v <- rt_vars]
199
	footer =
200
		[ ") ;; func"
201
		, ") ;; module"
202 203
		]

204
	block_body t = [")":head ++ [toString s \\ s <- reverse t.stmts]]
205 206 207
	where
		head = reverse [";; "+++i \\ i <- t.instrs]

208 209 210
	switch inner =
		[ if (inner && debug_instructions)
			(toString (Ecall "clean_debug_instr" [Pc, Eload I32 I32 DontCare 0 Pc]))
211
			""
212
		, "\t(br_table " +++
213 214 215
			foldr (+++) "" [find_label i (IF_SEPARATE_LOOPS (if inner fast_instrs slow_instrs) all_instructions) \\ i <- instrs_order] +++
			illegal_label +++
			(toString (Eload I32 I32 DontCare 0 Pc)) +++ ")"
216 217 218 219 220 221
		]
	where
		find_label i [t:ts]
		| isMember i t.instrs
			= "$instr_"+++hd t.instrs+++" "
			= find_label i ts
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 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
		find_label _ [] = illegal_label

		illegal_label = if (IF_SEPARATE_LOOPS inner False) "$slow-instr " "$instr_illegal "

	gc_block loop_label = IF_GLOBAL_RT_VARS
		[ ") ;; block abc-gc"
		, toString (Eset temp Hp_free)
		, toString (Ecall "clean_gc" [A])
		, toString (Eif (Hp_free <=. Ivar temp))
		,   "(then"
		,     toString (Ecall "clean_out_of_memory" [])
		,     toString Eunreachable
		,   ")"
		, ")"
		, toString (Ebr loop_label)
		, ") ;; loop abc-loop"
		]
		[ ") ;; block abc-gc"
		, toString (Ecall "clean_gc" [A])
		, toString (Eif (Ivar (Global "g-hp-free") <=. Hp_free))
		,   "(then"
		,     toString (Ecall "clean_out_of_memory" [])
		,     toString Eunreachable
		,   ")"
		, ")"
		, toString (Eset (from_Ivar Hp_free) (Ivar (Global "g-hp-free")))
		, toString (Eset (from_Ivar Hp) (Ivar (Global "g-hp")))
		, toString (Ebr loop_label)
		, ") ;; loop abc-loop"
		]
	where
		temp = IF_GLOBAL_TEMP_VARS Global Local "vw0"

type x :== Type TypeInferenceSettings x
type2 x y :== Type2 TypeInferenceSettings x y
TypeInferenceSettings =:
	{ inference_var_type = var
	}
where
	var (Variable loc v)
	| v.[0]=='v' = case v.[1] of
		'w' -> I32
		'q' -> I64
		'd' -> F64
	| v.[0]=='g' && v.[1]=='-' = var (Variable loc (v % (2,size v-1)))
	| v=="pc"      = I32
	| v=="asp"     = I32
	| v=="bsp"     = I32
	| v=="csp"     = I32
	| v=="hp"      = I32
	| v=="hp-free" = I32
	| v=="hp-size" = I32
274
	| v=="fast-ap-descriptor" = I64
275
	| otherwise    = abort ("unknown variable "+++v+++"\n")
276 277

instr_unimplemented :: !Target -> Target
278
instr_unimplemented t = (
279
	new_local (TPtr TWord) (Ecall "clean_handle_illegal_instr"
280 281 282 283 284 285 286
		[ Pc
		, Eload I32 I32 DontCare 0 Pc
		, A
		, B
		, Eget C
		, Hp
		, cast_expr Hp_free
287
		]) \res -> let new_pc = fix_type (TPtr TWord) res in
288
	if_then_else (to_word new_pc ==. lit_word 0) (
289
		append (Ecall "clean_illegal_instr"
290 291
			[ Pc
			, Eload I32 I32 DontCare 0 Pc
292
			]) :.
293 294 295 296 297 298 299
		append (Ereturn (Econst I32 1))
	) [] Nothing :.
	Pc .= new_pc
	) t
where
	fix_type :: !t !(Expr t) -> Expr t
	fix_type _ e = e
300 301

instr_halt :: !Target -> Target
302
instr_halt t = (
303
	append (Ecall "clean_halt" [cast_expr Pc, Hp_free, Eget (Global "g-hp-size")]) :.
304 305
	append (Ereturn (Econst I32 0))
	) t
306 307

instr_divLU :: !Target -> Target
308
instr_divLU t = instr_unimplemented t // TODO
309 310

instr_mulUUL :: !Target -> Target
311
instr_mulUUL t = instr_unimplemented t // TODO
312

313
instr_RtoAC :: !Target -> Target
314 315
instr_RtoAC t = (
	new_local TReal (to_real (B @ 0)) \r ->
316
	new_local TPtrOffset (Ecall "clean_RtoAC_words_needed" [r]) \lw ->
317
	ensure_hp lw :.
318
	A @ 1 .= to_word Hp :.
319
	Hp .= (Ecall "clean_RtoAC" [Hp,r] ::: TPtr TWord) :.
320 321 322 323
	advance_ptr Pc 1 :.
	advance_ptr A 1 :.
	advance_ptr B 1
	) t
324

325
lit_word :: !Int -> Expr TWord
326 327
lit_word w = Econst I64 w

328
lit_hword :: !Int -> Expr TPtrOffset
329
lit_hword w = Econst I32 w
330 331

lit_char :: !Char -> Expr TChar
332
lit_char c = Econst I64 c
333 334

lit_short :: !Int -> Expr TShort
335
lit_short s = Econst I64 s
336 337

lit_int :: !Int -> Expr TInt
338
lit_int i = Econst I64 i
339

340
instance to_word TBool    where to_word  c = Eextend I64 I32 c
341
instance to_word TPtrOffset   where to_word  c = Eextend I64 I32 c
342 343 344 345 346
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
347

348
instance to_bool  TWord   where to_bool  w = Ewrap I32 I64 w
349

350
instance to_char TWord    where to_char  w = cast_expr w
351

352
instance to_int TWord     where to_int   w = cast_expr w
353

354
instance to_real TWord    where to_real  w = Ereinterpret F64 I64 w
355

356 357 358 359 360 361
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
362

363 364 365 366
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

367 368 369 370
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
371
instance ^ (Expr TReal) where ^ a b = Ecall "clean_powR" [a,b]
372 373 374

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

376 377
(==.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(==.) a b = Eeq (type2 a b) a b
378

379 380
(<>.) infix  4 :: !(Expr a) !(Expr a) -> Expr TBool
(<>.) a b = Ene (type2 a b) a b
381

382 383
(<.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<.) a b = Elt (type2 a b) Signed a b
384

385 386
(>.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>.) a b = Egt (type2 a b) Signed a b
387

388 389
(<=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<=.) a b = Ele (type2 a b) Signed a b
390

391 392
(>=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>=.) a b = Ege (type2 a b) Signed a b
393

394
(&&.) infixr 3 :: !(Expr TBool) !(Expr TBool) -> Expr TBool
395
(&&.) a b = Eand (type2 a b) a b
396 397

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

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

403
(<<.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
404
(<<.) a b = Eshl (type2 a b) a b
405 406

(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
407
(>>.) a b = Eshr (type2 a b) Signed a b
408 409

xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
410
xorI a b = Exor (type2 a b) a b
411 412

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

absR :: !(Expr TReal) -> Expr TReal
416
absR r = Eabs (type r) r
417 418

acosR :: !(Expr TReal) -> Expr TReal
419
acosR r = Ecall "clean_acosR" [r]
420 421

asinR :: !(Expr TReal) -> Expr TReal
422
asinR r = Ecall "clean_asinR" [r]
423 424

atanR :: !(Expr TReal) -> Expr TReal
425
atanR r = Ecall "clean_atanR" [r]
426 427

cosR :: !(Expr TReal) -> Expr TReal
428
cosR r = Ecall "clean_cosR" [r]
429 430

entierR :: !(Expr TReal) -> Expr TInt
431
entierR r = Etrunc I64 F64 (Efloor F64 r)
432 433

expR :: !(Expr TReal) -> Expr TReal
434
expR r = Ecall "clean_expR" [r]
435 436

lnR :: !(Expr TReal) -> Expr TReal
437
lnR r = Ecall "clean_lnR" [r]
438 439

log10R :: !(Expr TReal) -> Expr TReal
440
log10R r = Ecall "clean_log10R" [r]
441 442

negR :: !(Expr TReal) -> Expr TReal
443
negR r = Eneg (type r) r
444 445

sinR :: !(Expr TReal) -> Expr TReal
446
sinR r = Ecall "clean_sinR" [r]
447 448

sqrtR :: !(Expr TReal) -> Expr TReal
449
sqrtR r = Esqrt (type r) r
450 451

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

454 455
ItoR :: !(Expr TInt)  -> Expr TReal
ItoR i = Econvert F64 I64 i
456 457

RtoI :: !(Expr TReal) -> Expr TInt
458
RtoI i = Etrunc I64 F64 i
459

460 461 462
if_i64_or_i32 :: !(Target -> Target) !(Target -> Target) !Target -> Target
if_i64_or_i32 i64 _ t = i64 t

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

466 467
if_expr :: !(Expr TBool) !(Expr t) !(Expr t) -> Expr t
if_expr c t e = Eselect t e c
468 469

begin_instruction :: !String !Target -> Target
470
begin_instruction name t = {t & instrs=[name:t.instrs], stmts=[]}
471 472

end_instruction :: !Target -> Target
473
end_instruction t = append (Ebr "abc-loop") t
474 475 476 477 478 479 480 481 482 483

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)

484 485 486 487
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)
488

489 490
set :: !Ex !Ex !Target -> Target
set var e t = append expr t
491
where
492 493 494 495 496 497 498
	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
499
instance .= TWord  TPtrOffset where .= v e t = set v (to_word e) t
500 501 502 503 504
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

505
instance .= TPtrOffset TPtrOffset where .= v e t = set v e t
506

507
instance .= TChar  TChar  where .= v e t = set v e t
508

509 510 511 512 513 514 515 516
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
517
		-> t
518 519 520 521 522 523 524 525 526
	_
		-> 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
527

528 529 530 531 532 533 534 535 536 537 538 539 540 541 542
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
543
instance += TPtrOffset TPtrOffset where += var val t = var_add var val t
544 545

instance -= TWord  TWord  where -= var val t = var_sub var val t
546
instance -= TPtrOffset TPtrOffset where -= var val t = var_sub var val t
547
instance -= TShort TShort where -= var val t = var_sub var val t
548

549 550
instance advance_ptr Int
where
551
	advance_ptr v e t = var_add v (Econst I32 (w*e)) t
552
	where
553
		w = type_width (wasm_type (get_type_of_ptr v))
554

555
instance advance_ptr (Expr TPtrOffset)
556
where
557
	advance_ptr v e t = var_add v (Eshl I32 e (Econst I32 s)) t
558
	where
559
		s = type_width_shift (wasm_type (get_type_of_ptr v))
560 561 562

instance rewind_ptr Int
where
563
	rewind_ptr v e t = var_sub v (Econst I32 (w*e)) t
564
	where
565
		w = type_width (wasm_type (get_type_of_ptr v))
566

567
instance rewind_ptr (Expr TPtrOffset)
568
where
569
	rewind_ptr v e t = var_sub v (Eshl I32 e (Econst I32 s)) t
570
	where
571 572 573 574 575 576 577
		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
}
578

579 580
instance @ Int
where
581 582 583
	@ p i
	| i >= 0 = Iref loc_type store_type idx p
	| otherwise = Iref loc_type store_type 0 (Esub I32 p (Econst I32 idx))
584
	where
585 586 587 588 589 590 591
		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
592 593 594

instance @ (Expr t)
where
595
	@ p e = Iref loc_type store_type 0 (p @? e)
596
	where
597 598 599 600 601
		store_type = wasm_type (get_type_of_ptr p)
		loc_type = case store_type of
			I8  -> I64
			I16 -> I64
			t   -> t
602 603 604

instance @? Int
where
605
	@? p i = if (i>=0) Eadd Esub I32 p (Econst I32 (abs i << s))
606
	where
607
		s = type_width_shift (wasm_type (get_type_of_ptr p))
608

609 610
instance @? (Expr t)
where
611
	@? p e
612
	# e = if (type e==I64) (Ewrap I32 I64 e) e
613 614
	| sft == 0  = Eadd I32 p e
	| otherwise = Eadd I32 p (Eshl I32 e (Econst I32 sft))
615
	where
616 617
		ptr_type = wasm_type (get_type_of_ptr p)
		sft = type_width_shift ptr_type
618

619
begin_block :: !Target -> Target
620
begin_block t = append Eblock t
621 622

end_block :: !Target -> Target
623 624 625 626 627 628 629 630 631 632 633 634
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
635 636

break :: !Target -> Target
637
break t = append (Ebr_local 1) t
638

639
if_then_else ::
640 641
	!(Expr TBool) !(Target -> Target)
	![(Expr TBool, Target -> Target)]
642 643
	!(Maybe (Target -> Target))
	!Target -> Target
644
if_then_else c then elifs else t =
645 646
	iter (2*length elifs) (append Eend)
	(append Eend
647 648
	(mbelse
	(foldl elif
649 650
		(append Eend (then (append Ethen
			(append (Eif c) t))))
651 652 653 654
		elifs)))
where
	mbelse t = case else of
		Nothing -> t
655
		Just e  -> append Eend (e (append Eelse t))
656

657
	elif t (cond, block) = append Eend (block (append Ethen (append (Eif cond) (append Eelse t))))
658

659 660
if_break_else :: !(Expr TBool) !(Target -> Target) !Target -> Target
if_break_else c else t = else (append (Ebr_if 0 c) t)
661

662
instance ensure_hp (Expr t) | to_ptr_offset t
663
where
664 665 666 667 668 669 670 671 672 673 674 675
	ensure_hp i t = real_ensure_hp (to_ptr_offset i) t

instance ensure_hp Ex  where ensure_hp i t = real_ensure_hp i t
instance ensure_hp Int where ensure_hp i t = real_ensure_hp (Econst I32 i) t

real_ensure_hp :: !(Expr TPtrOffset) !Target -> Target
real_ensure_hp e t = if_then_else
	(Elt I32 Signed Hp_free (Econst I32 0))
	(Hp_free += e :. append (Ebr "abc-gc"))
	[]
	Nothing
	((Hp_free .= Hp_free - e) t)
676 677

A :: Expr (TPtr TWord)
678
A = Ivar (rt_var "asp")
679 680

B :: Expr (TPtr TWord)
681
B = Ivar (rt_var "bsp")
682 683

Pc :: Expr (TPtr TWord)
684
Pc = Ivar (rt_var "pc")
685 686

Hp :: Expr (TPtr TWord)
687
Hp = Ivar (rt_var "hp")
688

689
Hp_free :: Expr TPtrOffset
690
Hp_free = Ivar (rt_var "hp-free")
691 692

BOOL_ptr :: Expr TWord
693
BOOL_ptr = Econst I64 (11*8)
694 695

CHAR_ptr :: Expr TWord
696
CHAR_ptr = Econst I64 (16*8)
697 698

INT_ptr :: Expr TWord
699
INT_ptr = Econst I64 (26*8)
700 701

REAL_ptr :: Expr TWord
702
REAL_ptr = Econst I64 (21*8)
703 704

ARRAY__ptr :: Expr TWord
705
ARRAY__ptr = Econst I64 (1*8)
706 707

STRING__ptr :: Expr TWord
708
STRING__ptr = Econst I64 (6*8)
709

710 711
jmp_ap_ptr :: !Int -> Expr (TPtr TWord)
jmp_ap_ptr i = Econst I32 ((99+i)*8)
712 713

cycle_ptr :: Expr TWord
714
cycle_ptr = Econst I64 (131*8)
715 716

indirection_ptr :: Expr TWord
717
indirection_ptr = Econst I64 ((131+1+5)*8)
718 719

dNil_ptr :: Expr TWord
720
dNil_ptr = Econst I64 ((141+1)*8)
721 722

small_integer :: !(Expr TInt) -> Expr TWord
723
small_integer i = Eadd I64 (Econst I64 (8*31)) (Eshl I64 i (Econst I64 4))
724 725

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

Camil Staps's avatar
Camil Staps committed
728 729
static_boolean :: !(Expr TWord) -> Expr TWord
static_boolean b = case b of
730 731
	Econst _ i -> if (is_zero i) FALSE TRUE
	b          -> if_expr (Ewrap I32 I64 b) TRUE FALSE
Camil Staps's avatar
Camil Staps committed
732
where
733 734
	TRUE  = Econst I64 (8*668)
	FALSE = Econst I64 (8*666)
Camil Staps's avatar
Camil Staps committed
735

736
caf_list :: Expr (TPtr TWord)
737
caf_list = Econst I32 (97*8)
738

739 740 741
fast_ap_descriptor :: Expr TWord
fast_ap_descriptor = Ivar (Global "g-fast-ap-descriptor")

742
C = rt_var "csp"
743

744 745 746 747 748
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
749

750
pop_pc_from_c :: !Target -> Target
751 752 753 754 755 756 757
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)
758

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

762
strncmp :: !(Expr (TPtr TChar)) !(Expr (TPtr TChar)) !(Expr TPtrOffset) -> Expr TInt
763
strncmp s1 s2 n = Eextend I64 I32 (Ecall "clean_strncmp" [s1,s2,cast_expr n])
764 765

putchar :: !(Expr TChar) !Target -> Target
766
putchar c t = append (Ecall "clean_putchar" [Ewrap I32 I64 c]) t
767 768

print_bool :: !(Expr TWord) !Target -> Target
769
print_bool c t = append (Ecall "clean_print_bool" [Ewrap I32 I64 c]) t
770 771

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

print_int :: !(Expr TInt) !Target -> Target
775
print_int c t = append (Ecall "clean_print_int" [high,low]) t
776
where
777 778
	high = Ewrap I32 I64 (Eshr I64 Unsigned c (Econst I64 32))
	low = Ewrap I32 I64 c
779 780

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