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 112 113 114
		[ "(block $slow-instr"
		, "(loop $abc-loop" ]
	)
		[ "(block $abc-gc"
		, "(loop $abc-loop" ]
	++
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] ++
118
	IF_SEPARATE_LOOPS [") ;; abc-loop"] (gc_block "abc-loop") ++
119 120 121 122 123 124 125
	IF_SEPARATE_LOOPS (
		[ ") ;; block slow-instr" ] ++
		switch False ++
		flatten [block_body {i & stmts=map (optimize slow_opt_options) i.stmts} \\ i <- slow_instrs] ++
		gc_block "abc-loop-outer")
		[] ++
	[ "(unreachable)" ] ++
126
	footer
127
where
128 129 130 131
	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
132
	where
133
		may_need_gc i = any (any (\e->e=:(Ebr "abc-gc")) o subexpressions) i.stmts
134

135 136 137 138 139
	// 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 _ [] = ([],[])
140 141
	fast_opt_options = {rename_labels=[]}
	slow_opt_options = {rename_labels=[("abc-loop","abc-loop-outer"),("abc-gc","abc-gc-outer")]}
142 143

	header =
144 145
		[ "(module"
		, "(import \"clean\" \"memory\" (memory 1))"
146

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

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

181 182 183 184
		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]]] [] ++

185
		[ "(func (export \"interpret\") (result i32)" ] ++
186 187 188

		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]]] ++
189 190 191 192
		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]
193
	footer =
194
		[ ") ;; func"
195
		, ") ;; module"
196 197
		]

198
	block_body t = [")":head ++ [toString s \\ s <- reverse t.stmts]]
199 200 201
	where
		head = reverse [";; "+++i \\ i <- t.instrs]

202 203 204
	switch inner =
		[ if (inner && debug_instructions)
			(toString (Ecall "clean_debug_instr" [Pc, Eload I32 I32 DontCare 0 Pc]))
205
			""
206
		, "\t(br_table " +++
207 208 209
			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)) +++ ")"
210 211 212 213 214 215
		]
	where
		find_label i [t:ts]
		| isMember i t.instrs
			= "$instr_"+++hd t.instrs+++" "
			= find_label i ts
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 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
		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
	| otherwise    = abort ("unknown variable "+++v+++"\n")
269 270

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

instr_halt :: !Target -> Target
295
instr_halt t = (
296
	append (Ecall "clean_halt" [cast_expr Pc, Hp_free, Eget (Global "g-hp-size")]) :.
297 298
	append (Ereturn (Econst I32 0))
	) t
299 300

instr_divLU :: !Target -> Target
301
instr_divLU t = instr_unimplemented t // TODO
302 303

instr_mulUUL :: !Target -> Target
304
instr_mulUUL t = instr_unimplemented t // TODO
305

306
instr_RtoAC :: !Target -> Target
307 308
instr_RtoAC t = (
	new_local TReal (to_real (B @ 0)) \r ->
309
	new_local TPtrOffset (Ecall "clean_RtoAC_words_needed" [r]) \lw ->
310
	//ensure_hp (lw ::: TPtrOffset) :. // TODO
311
	A @ 1 .= to_word Hp :.
312
	Hp .= (Ecall "clean_RtoAC" [Hp,r] ::: TPtr TWord) :.
313 314 315 316 317 318 319
	advance_ptr Pc 1 :.
	advance_ptr A 1 :.
	advance_ptr B 1
	) t
where
	(:::) :: !(Expr t) t -> Expr t
	(:::) e _ = e
320

321
lit_word :: !Int -> Expr TWord
322 323
lit_word w = Econst I64 w

324
lit_hword :: !Int -> Expr TPtrOffset
325
lit_hword w = Econst I32 w
326 327

lit_char :: !Char -> Expr TChar
328
lit_char c = Econst I64 c
329 330

lit_short :: !Int -> Expr TShort
331
lit_short s = Econst I64 s
332 333

lit_int :: !Int -> Expr TInt
334
lit_int i = Econst I64 i
335

336
instance to_word TBool    where to_word  c = Eextend I64 I32 c
337
instance to_word TPtrOffset   where to_word  c = Eextend I64 I32 c
338 339 340 341 342
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
343

344
instance to_bool  TWord   where to_bool  w = Ewrap I32 I64 w
345

346
instance to_char TWord    where to_char  w = cast_expr w
347

348
instance to_int TWord     where to_int   w = cast_expr w
349

350
instance to_real TWord    where to_real  w = Ereinterpret F64 I64 w
351

352 353 354 355 356 357
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
358

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

363 364 365 366
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
367
instance ^ (Expr TReal) where ^ a b = Ecall "clean_powR" [a,b]
368 369 370

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

372 373
(==.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(==.) a b = Eeq (type2 a b) a b
374

375 376
(<>.) infix  4 :: !(Expr a) !(Expr a) -> Expr TBool
(<>.) a b = Ene (type2 a b) a b
377

378 379
(<.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<.) a b = Elt (type2 a b) Signed a b
380

381 382
(>.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>.) a b = Egt (type2 a b) Signed a b
383

384 385
(<=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(<=.) a b = Ele (type2 a b) Signed a b
386

387 388
(>=.) infix 4 :: !(Expr a) !(Expr a) -> Expr TBool
(>=.) a b = Ege (type2 a b) Signed a b
389

390
(&&.) infixr 3 :: !(Expr TBool) !(Expr TBool) -> Expr TBool
391
(&&.) a b = Eand (type2 a b) a b
392 393

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

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

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

(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
403
(>>.) a b = Eshr (type2 a b) Signed a b
404 405

xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
406
xorI a b = Exor (type2 a b) a b
407 408

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

absR :: !(Expr TReal) -> Expr TReal
412
absR r = Eabs (type r) r
413 414

acosR :: !(Expr TReal) -> Expr TReal
415
acosR r = Ecall "clean_acosR" [r]
416 417

asinR :: !(Expr TReal) -> Expr TReal
418
asinR r = Ecall "clean_asinR" [r]
419 420

atanR :: !(Expr TReal) -> Expr TReal
421
atanR r = Ecall "clean_atanR" [r]
422 423

cosR :: !(Expr TReal) -> Expr TReal
424
cosR r = Ecall "clean_cosR" [r]
425 426

entierR :: !(Expr TReal) -> Expr TInt
427
entierR r = Etrunc I64 F64 (Efloor F64 r)
428 429

expR :: !(Expr TReal) -> Expr TReal
430
expR r = Ecall "clean_expR" [r]
431 432

lnR :: !(Expr TReal) -> Expr TReal
433
lnR r = Ecall "clean_lnR" [r]
434 435

log10R :: !(Expr TReal) -> Expr TReal
436
log10R r = Ecall "clean_log10R" [r]
437 438

negR :: !(Expr TReal) -> Expr TReal
439
negR r = Eneg (type r) r
440 441

sinR :: !(Expr TReal) -> Expr TReal
442
sinR r = Ecall "clean_sinR" [r]
443 444

sqrtR :: !(Expr TReal) -> Expr TReal
445
sqrtR r = Esqrt (type r) r
446 447

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

450 451
ItoR :: !(Expr TInt)  -> Expr TReal
ItoR i = Econvert F64 I64 i
452 453

RtoI :: !(Expr TReal) -> Expr TInt
454
RtoI i = Etrunc I64 F64 i
455

456 457 458
if_i64_or_i32 :: !(Target -> Target) !(Target -> Target) !Target -> Target
if_i64_or_i32 i64 _ t = i64 t

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

462 463
if_expr :: !(Expr TBool) !(Expr t) !(Expr t) -> Expr t
if_expr c t e = Eselect t e c
464 465

begin_instruction :: !String !Target -> Target
466
begin_instruction name t = {t & instrs=[name:t.instrs], stmts=[]}
467 468

end_instruction :: !Target -> Target
469
end_instruction t = append (Ebr "abc-loop") t
470 471 472 473 474 475 476 477 478 479

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)

480 481 482 483
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)
484

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

501
instance .= TPtrOffset TPtrOffset where .= v e t = set v e t
502

503
instance .= TChar  TChar  where .= v e t = set v e t
504

505 506 507 508 509 510 511 512
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
513
		-> t
514 515 516 517 518 519 520 521 522
	_
		-> 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
523

524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
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
539
instance += TPtrOffset TPtrOffset where += var val t = var_add var val t
540 541

instance -= TWord  TWord  where -= var val t = var_sub var val t
542
instance -= TPtrOffset TPtrOffset where -= var val t = var_sub var val t
543
instance -= TShort TShort where -= var val t = var_sub var val t
544

545 546
instance advance_ptr Int
where
547
	advance_ptr v e t = var_add v (Econst I32 (w*e)) t
548
	where
549
		w = type_width (wasm_type (get_type_of_ptr v))
550

551
instance advance_ptr (Expr TPtrOffset)
552
where
553
	advance_ptr v e t = var_add v (Eshl I32 e (Econst I32 s)) t
554
	where
555
		s = type_width_shift (wasm_type (get_type_of_ptr v))
556 557 558

instance rewind_ptr Int
where
559
	rewind_ptr v e t = var_sub v (Econst I32 (w*e)) t
560
	where
561
		w = type_width (wasm_type (get_type_of_ptr v))
562

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

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

instance @ (Expr t)
where
591
	@ p e = Iref loc_type store_type 0 (p @? e)
592
	where
593 594 595 596 597
		store_type = wasm_type (get_type_of_ptr p)
		loc_type = case store_type of
			I8  -> I64
			I16 -> I64
			t   -> t
598 599 600

instance @? Int
where
601
	@? p i = if (i>=0) Eadd Esub I32 p (Econst I32 (abs i << s))
602
	where
603
		s = type_width_shift (wasm_type (get_type_of_ptr p))
604

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

615
begin_block :: !Target -> Target
616
begin_block t = append Eblock t
617 618

end_block :: !Target -> Target
619 620 621 622 623 624 625 626 627 628 629 630
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
631 632

break :: !Target -> Target
633
break t = append (Ebr_local 1) t
634

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

653
	elif t (cond, block) = append Eend (block (append Ethen (append (Eif cond) (append Eelse t))))
654

655 656
if_break_else :: !(Expr TBool) !(Target -> Target) !Target -> Target
if_break_else c else t = else (append (Ebr_if 0 c) t)
657

658
instance ensure_hp (Expr t) | to_ptr_offset t
659
where
660 661
	ensure_hp i t = if_then_else
		(Elt I32 Signed Hp_free (Econst I32 0))
662
		(Hp_free += to_ptr_offset i :. append (Ebr "abc-gc"))
663 664
		[]
		Nothing
665
		((Hp_free .= Hp_free - to_ptr_offset i) t)
666

667
instance ensure_hp Int
668 669
where
	ensure_hp i t = if_then_else
670 671
		(Elt I32 Signed Hp_free (Econst I32 0))
		(Hp_free += ie :. append (Ebr "abc-gc"))
672 673
		[]
		Nothing
674 675
		((Hp_free .= Hp_free - ie) t)
	where
676
		ie :: Expr TPtrOffset
677
		ie = Econst I32 i
678 679

A :: Expr (TPtr TWord)
680
A = Ivar (rt_var "asp")
681 682

B :: Expr (TPtr TWord)
683
B = Ivar (rt_var "bsp")
684 685

Pc :: Expr (TPtr TWord)
686
Pc = Ivar (rt_var "pc")
687 688

Hp :: Expr (TPtr TWord)
689
Hp = Ivar (rt_var "hp")
690

691
Hp_free :: Expr TPtrOffset
692
Hp_free = Ivar (rt_var "hp-free")
693 694

BOOL_ptr :: Expr TWord
695
BOOL_ptr = Econst I64 (11*8)
696 697

CHAR_ptr :: Expr TWord
698
CHAR_ptr = Econst I64 (16*8)
699 700

INT_ptr :: Expr TWord
701
INT_ptr = Econst I64 (26*8)
702 703

REAL_ptr :: Expr TWord
704
REAL_ptr = Econst I64 (21*8)
705 706

ARRAY__ptr :: Expr TWord
707
ARRAY__ptr = Econst I64 (1*8)
708 709

STRING__ptr :: Expr TWord
710
STRING__ptr = Econst I64 (6*8)
711

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

cycle_ptr :: Expr TWord
716
cycle_ptr = Econst I64 (131*8)
717 718

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

dNil_ptr :: Expr TWord
722
dNil_ptr = Econst I64 ((141+1)*8)
723 724

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

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

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

738
caf_list :: Expr (TPtr TWord)
739
caf_list = Econst I32 (97*8)
740

741
C = rt_var "csp"
742

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

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

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

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

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

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

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

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

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