ocaml-base-compiler.4.10.0/middle_end/closure/closure.ml

1

(**************************************************************************)

2

(* *)

3

(* OCaml *)

4

(* *)

5

(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)

6

(* *)

7

8

(* en Automatique. *)

9

(* *)

10

11

(* the GNU Lesser General Public License version 2.1, with the *)

12

(* special exception on linking described in the file LICENSE. *)

13

(* *)

14

(**************************************************************************)

15

16

(* Introduction of closures, uncurrying, recognition of direct calls *)

17

18

open Misc

19

open Asttypes

20

open Primitive

21

open Lambda

22

open Switch

23

open Clambda

24

module P = Clambda_primitives

25

26

module Int = Numbers.Int

27

module Storer =

28

Switch.Store

29

(struct

30

type t = lambda

31

type key = lambda

32

let make_key = Lambda.make_key

33

let compare_key = Stdlib.compare

34

end)

35

36

module V = Backend_var

37

module VP = Backend_var.With_provenance

38

39

(* The current backend *)

40

41

let no_phantom_lets () =

42

Misc.fatal_error "Closure does not support phantom let generation"

43

44

(* Auxiliaries for compiling functions *)

45

46

let rec split_list n l =

47

if n <= 0 then ([], l) else begin

48

match l with

49

[] -> fatal_error "Closure.split_list"

50

| a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2)

51

end

52

53

let rec build_closure_env env_param pos = function

54

[] -> V.Map.empty

55

| id :: rem ->

56

V.Map.add id

57

(Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none))

58

(build_closure_env env_param (pos+1) rem)

59

60

(* Auxiliary for accessing globals. We change the name of the global

61

to the name of the corresponding asm symbol. This is done here

62

and no longer in Cmmgen so that approximations stored in .cmx files

63

contain the right names if the -for-pack option is active. *)

64

65

let getglobal dbg id =

66

Uprim(P.Pread_symbol (Compilenv.symbol_for_global id), [], dbg)

67

68

(* Check if a variable occurs in a [clambda] term. *)

69

70

let occurs_var var u =

71

let rec occurs = function

72

Uvar v -> v = var

73

| Uconst _ -> false

74

| Udirect_apply(_lbl, args, _) -> List.exists occurs args

75

| Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args

76

| Uclosure(_fundecls, clos) -> List.exists occurs clos

77

| Uoffset(u, _ofs) -> occurs u

78

| Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body

79

| Uphantom_let _ -> no_phantom_lets ()

80

| Uletrec(decls, body) ->

81

List.exists (fun (_id, u) -> occurs u) decls || occurs body

82

| Uprim(_p, args, _) -> List.exists occurs args

83

| Uswitch(arg, s, _dbg) ->

84

occurs arg ||

85

occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks

86

| Ustringswitch(arg,sw,d) ->

87

occurs arg ||

88

List.exists (fun (_,e) -> occurs e) sw ||

89

(match d with None -> false | Some d -> occurs d)

90

| Ustaticfail (_, args) -> List.exists occurs args

91

| Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr

92

| Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr

93

| Uifthenelse(cond, ifso, ifnot) ->

94

occurs cond || occurs ifso || occurs ifnot

95

| Usequence(u1, u2) -> occurs u1 || occurs u2

96

| Uwhile(cond, body) -> occurs cond || occurs body

97

| Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body

98

| Uassign(id, u) -> id = var || occurs u

99

| Usend(_, met, obj, args, _) ->

100

occurs met || occurs obj || List.exists occurs args

101

| Uunreachable -> false

102

and occurs_array a =

103

try

104

for i = 0 to Array.length a - 1 do

105

if occurs a.(i) then raise Exit

106

done;

107

false

108

with Exit ->

109

true

110

in occurs u

111

112

(* Determine whether the estimated size of a clambda term is below

113

some threshold *)

114

115

let prim_size prim args =

116

let open Clambda_primitives in

117

match prim with

118

| Pread_symbol _ -> 1

119

| Pmakeblock _ -> 5 + List.length args

120

| Pfield _ -> 1

121

| Psetfield(_f, isptr, init) ->

122

begin match init with

123

| Root_initialization -> 1 (* never causes a write barrier hit *)

124

| Assignment | Heap_initialization ->

125

match isptr with

126

| Pointer -> 4

127

| Immediate -> 1

128

end

129

| Pfloatfield _ -> 1

130

| Psetfloatfield _ -> 1

131

| Pduprecord _ -> 10 + List.length args

132

| Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args

133

| Praise _ -> 4

134

| Pstringlength -> 5

135

| Pbyteslength -> 5

136

| Pstringrefs -> 6

137

| Pbytesrefs | Pbytessets -> 6

138

| Pmakearray _ -> 5 + List.length args

139

| Parraylength kind -> if kind = Pgenarray then 6 else 2

140

| Parrayrefu kind -> if kind = Pgenarray then 12 else 2

141

| Parraysetu kind -> if kind = Pgenarray then 16 else 4

142

| Parrayrefs kind -> if kind = Pgenarray then 18 else 8

143

| Parraysets kind -> if kind = Pgenarray then 22 else 10

144

| Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6

145

| Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6

146

| _ -> 2 (* arithmetic and comparisons *)

147

148

(* Very raw approximation of switch cost *)

149

150

let lambda_smaller lam threshold =

151

let size = ref 0 in

152

let rec lambda_size lam =

153

if !size > threshold then raise Exit;

154

match lam with

155

Uvar _ -> ()

156

| Uconst _ -> incr size

157

| Udirect_apply(_, args, _) ->

158

size := !size + 4; lambda_list_size args

159

| Ugeneric_apply(fn, args, _) ->

160

size := !size + 6; lambda_size fn; lambda_list_size args

161

| Uclosure _ ->

162

raise Exit (* inlining would duplicate function definitions *)

163

| Uoffset(lam, _ofs) ->

164

incr size; lambda_size lam

165

| Ulet(_str, _kind, _id, lam, body) ->

166

lambda_size lam; lambda_size body

167

| Uphantom_let _ -> no_phantom_lets ()

168

| Uletrec _ ->

169

raise Exit (* usually too large *)

170

| Uprim(prim, args, _) ->

171

size := !size + prim_size prim args;

172

lambda_list_size args

173

| Uswitch(lam, cases, _dbg) ->

174

if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;

175

if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;

176

lambda_size lam;

177

lambda_array_size cases.us_actions_consts ;

178

lambda_array_size cases.us_actions_blocks

179

| Ustringswitch (lam,sw,d) ->

180

lambda_size lam ;

181

(* as ifthenelse *)

182

List.iter

183

(fun (_,lam) ->

184

size := !size+2 ;

185

lambda_size lam)

186

sw ;

187

Option.iter lambda_size d

188

| Ustaticfail (_,args) -> lambda_list_size args

189

| Ucatch(_, _, body, handler) ->

190

incr size; lambda_size body; lambda_size handler

191

| Utrywith(body, _id, handler) ->

192

size := !size + 8; lambda_size body; lambda_size handler

193

| Uifthenelse(cond, ifso, ifnot) ->

194

size := !size + 2;

195

lambda_size cond; lambda_size ifso; lambda_size ifnot

196

| Usequence(lam1, lam2) ->

197

lambda_size lam1; lambda_size lam2

198

| Uwhile(cond, body) ->

199

size := !size + 2; lambda_size cond; lambda_size body

200

| Ufor(_id, low, high, _dir, body) ->

201

size := !size + 4; lambda_size low; lambda_size high; lambda_size body

202

| Uassign(_id, lam) ->

203

incr size; lambda_size lam

204

| Usend(_, met, obj, args, _) ->

205

size := !size + 8;

206

lambda_size met; lambda_size obj; lambda_list_size args

207

| Uunreachable -> ()

208

and lambda_list_size l = List.iter lambda_size l

209

and lambda_array_size a = Array.iter lambda_size a in

210

try

211

lambda_size lam; !size <= threshold

212

with Exit ->

213

false

214

215

let is_pure_prim p =

216

let open Semantics_of_primitives in

217

match Semantics_of_primitives.for_primitive p with

218

| (No_effects | Only_generative_effects), _ -> true

219

| Arbitrary_effects, _ -> false

220

221

(* Check if a clambda term is ``pure'',

222

that is without side-effects *and* not containing function definitions *)

223

224

let rec is_pure = function

225

Uvar _ -> true

226

| Uconst _ -> true

227

| Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args

228

| Uoffset(arg, _) -> is_pure arg

229

| Ulet(Immutable, _, _var, def, body) ->

230

is_pure def && is_pure body

231

| _ -> false

232

233

(* Simplify primitive operations on known arguments *)

234

235

let make_const c = (Uconst c, Value_const c)

236

let make_const_ref c =

237

make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c,

238

Some c))

239

let make_const_int n = make_const (Uconst_int n)

240

let make_const_ptr n = make_const (Uconst_ptr n)

241

let make_const_bool b = make_const_ptr(if b then 1 else 0)

242

243

let make_integer_comparison cmp x y =

244

let open Clambda_primitives in

245

make_const_bool

246

(match cmp with

247

Ceq -> x = y

248

| Cne -> x <> y

249

| Clt -> x < y

250

| Cgt -> x > y

251

| Cle -> x <= y

252

| Cge -> x >= y)

253

254

let make_float_comparison cmp x y =

255

make_const_bool

256

(match cmp with

257

| CFeq -> x = y

258

| CFneq -> not (x = y)

259

| CFlt -> x < y

260

| CFnlt -> not (x < y)

261

| CFgt -> x > y

262

| CFngt -> not (x > y)

263

| CFle -> x <= y

264

| CFnle -> not (x <= y)

265

| CFge -> x >= y

266

| CFnge -> not (x >= y))

267

268

let make_const_float n = make_const_ref (Uconst_float n)

269

let make_const_natint n = make_const_ref (Uconst_nativeint n)

270

let make_const_int32 n = make_const_ref (Uconst_int32 n)

271

let make_const_int64 n = make_const_ref (Uconst_int64 n)

272

273

(* The [fpc] parameter is true if constant propagation of

274

floating-point computations is allowed *)

275

276

let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg =

277

let module B = (val backend : Backend_intf.S) in

278

let open Clambda_primitives in

279

let default = (Uprim(p, args, dbg), Value_unknown) in

280

match approxs with

281

(* int (or enumerated type) *)

282

| [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] ->

283

begin match p with

284

| Pnot -> make_const_bool (n1 = 0)

285

| Pnegint -> make_const_int (- n1)

286

| Poffsetint n -> make_const_int (n + n1)

287

| Pfloatofint when fpc -> make_const_float (float_of_int n1)

288

| Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1)

289

| Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1)

290

| Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1)

291

| Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8)

292

lor ((n1 land 0xff00) lsr 8))

293

| _ -> default

294

end

295

(* int (or enumerated type), int (or enumerated type) *)

296

| [ Value_const(Uconst_int n1 | Uconst_ptr n1);

297

Value_const(Uconst_int n2 | Uconst_ptr n2) ] ->

298

begin match p with

299

| Psequand -> make_const_bool (n1 <> 0 && n2 <> 0)

300

| Psequor -> make_const_bool (n1 <> 0 || n2 <> 0)

301

| Paddint -> make_const_int (n1 + n2)

302

| Psubint -> make_const_int (n1 - n2)

303

| Pmulint -> make_const_int (n1 * n2)

304

| Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2)

305

| Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2)

306

| Pandint -> make_const_int (n1 land n2)

307

| Porint -> make_const_int (n1 lor n2)

308

| Pxorint -> make_const_int (n1 lxor n2)

309

| Plslint when 0 <= n2 && n2 < 8 * B.size_int ->

310

make_const_int (n1 lsl n2)

311

| Plsrint when 0 <= n2 && n2 < 8 * B.size_int ->

312

make_const_int (n1 lsr n2)

313

| Pasrint when 0 <= n2 && n2 < 8 * B.size_int ->

314

make_const_int (n1 asr n2)

315

| Pintcomp c -> make_integer_comparison c n1 n2

316

| _ -> default

317

end

318

(* float *)

319

| [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc ->

320

begin match p with

321

| Pintoffloat -> make_const_int (int_of_float n1)

322

| Pnegfloat -> make_const_float (-. n1)

323

| Pabsfloat -> make_const_float (abs_float n1)

324

| _ -> default

325

end

326

(* float, float *)

327

| [Value_const(Uconst_ref(_, Some (Uconst_float n1)));

328

Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc ->

329

begin match p with

330

| Paddfloat -> make_const_float (n1 +. n2)

331

| Psubfloat -> make_const_float (n1 -. n2)

332

| Pmulfloat -> make_const_float (n1 *. n2)

333

| Pdivfloat -> make_const_float (n1 /. n2)

334

| Pfloatcomp c -> make_float_comparison c n1 n2

335

| _ -> default

336

end

337

(* nativeint *)

338

| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] ->

339

begin match p with

340

| Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n)

341

| Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n)

342

| Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n)

343

| Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n)

344

| _ -> default

345

end

346

(* nativeint, nativeint *)

347

| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));

348

Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] ->

349

begin match p with

350

| Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)

351

| Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)

352

| Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2)

353

| Pdivbint {size=Pnativeint} when n2 <> 0n ->

354

make_const_natint (Nativeint.div n1 n2)

355

| Pmodbint {size=Pnativeint} when n2 <> 0n ->

356

make_const_natint (Nativeint.rem n1 n2)

357

| Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)

358

| Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2)

359

| Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2)

360

| Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2

361

| _ -> default

362

end

363

(* nativeint, int *)

364

| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));

365

Value_const(Uconst_int n2)] ->

366

begin match p with

367

| Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->

368

make_const_natint (Nativeint.shift_left n1 n2)

369

| Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->

370

make_const_natint (Nativeint.shift_right_logical n1 n2)

371

| Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->

372

make_const_natint (Nativeint.shift_right n1 n2)

373

| _ -> default

374

end

375

(* int32 *)

376

| [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] ->

377

begin match p with

378

| Pintofbint Pint32 -> make_const_int (Int32.to_int n)

379

| Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n)

380

| Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n)

381

| Pnegbint Pint32 -> make_const_int32 (Int32.neg n)

382

| _ -> default

383

end

384

(* int32, int32 *)

385

| [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));

386

Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] ->

387

begin match p with

388

| Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)

389

| Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)

390

| Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2)

391

| Pdivbint {size=Pint32} when n2 <> 0l ->

392

make_const_int32 (Int32.div n1 n2)

393

| Pmodbint {size=Pint32} when n2 <> 0l ->

394

make_const_int32 (Int32.rem n1 n2)

395

| Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)

396

| Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)

397

| Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)

398

| Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2

399

| _ -> default

400

end

401

(* int32, int *)

402

| [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));

403

Value_const(Uconst_int n2)] ->

404

begin match p with

405

| Plslbint Pint32 when 0 <= n2 && n2 < 32 ->

406

make_const_int32 (Int32.shift_left n1 n2)

407

| Plsrbint Pint32 when 0 <= n2 && n2 < 32 ->

408

make_const_int32 (Int32.shift_right_logical n1 n2)

409

| Pasrbint Pint32 when 0 <= n2 && n2 < 32 ->

410

make_const_int32 (Int32.shift_right n1 n2)

411

| _ -> default

412

end

413

(* int64 *)

414

| [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] ->

415

begin match p with

416

| Pintofbint Pint64 -> make_const_int (Int64.to_int n)

417

| Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n)

418

| Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n)

419

| Pnegbint Pint64 -> make_const_int64 (Int64.neg n)

420

| _ -> default

421

end

422

(* int64, int64 *)

423

| [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));

424

Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] ->

425

begin match p with

426

| Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)

427

| Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)

428

| Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2)

429

| Pdivbint {size=Pint64} when n2 <> 0L ->

430

make_const_int64 (Int64.div n1 n2)

431

| Pmodbint {size=Pint64} when n2 <> 0L ->

432

make_const_int64 (Int64.rem n1 n2)

433

| Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)

434

| Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)

435

| Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)

436

| Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2

437

| _ -> default

438

end

439

(* int64, int *)

440

| [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));

441

Value_const(Uconst_int n2)] ->

442

begin match p with

443

| Plslbint Pint64 when 0 <= n2 && n2 < 64 ->

444

make_const_int64 (Int64.shift_left n1 n2)

445

| Plsrbint Pint64 when 0 <= n2 && n2 < 64 ->

446

make_const_int64 (Int64.shift_right_logical n1 n2)

447

| Pasrbint Pint64 when 0 <= n2 && n2 < 64 ->

448

make_const_int64 (Int64.shift_right n1 n2)

449

| _ -> default

450

end

451

(* TODO: Pbbswap *)

452

(* Catch-all *)

453

| _ ->

454

default

455

456

let field_approx n = function

457

| Value_tuple a when n < Array.length a -> a.(n)

458

| Value_const (Uconst_ref(_, Some (Uconst_block(_, l))))

459

when n < List.length l ->

460

Value_const (List.nth l n)

461

| _ -> Value_unknown

462

463

let simplif_prim_pure ~backend fpc p (args, approxs) dbg =

464

let open Clambda_primitives in

465

match p, args, approxs with

466

(* Block construction *)

467

| Pmakeblock(tag, Immutable, _kind), _, _ ->

468

let field = function

469

| Value_const c -> c

470

| _ -> raise Exit

471

in

472

begin try

473

let cst = Uconst_block (tag, List.map field approxs) in

474

let name =

475

Compilenv.new_structured_constant cst ~shared:true

476

in

477

make_const (Uconst_ref (name, Some cst))

478

with Exit ->

479

(Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))

480

end

481

(* Field access *)

482

| Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]

483

when n < List.length l ->

484

make_const (List.nth l n)

485

| Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]

486

when n < List.length ul ->

487

(List.nth ul n, field_approx n approx)

488

(* Strings *)

489

| (Pstringlength | Pbyteslength),

490

_,

491

[ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->

492

make_const_int (String.length s)

493

(* Kind test *)

494

| Pisint, _, [a1] ->

495

begin match a1 with

496

| Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true

497

| Value_const(Uconst_ref _) -> make_const_bool false

498

| Value_closure _ | Value_tuple _ -> make_const_bool false

499

| _ -> (Uprim(p, args, dbg), Value_unknown)

500

end

501

(* Catch-all *)

502

| _ ->

503

simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg

504

505

let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg =

506

if List.for_all is_pure args

507

then simplif_prim_pure ~backend fpc p args_approxs dbg

508

else

509

(* XXX : always return the same approxs as simplif_prim_pure? *)

510

let approx =

511

match p with

512

| P.Pmakeblock(_, Immutable, _kind) ->

513

Value_tuple (Array.of_list approxs)

514

| _ ->

515

Value_unknown

516

in

517

(Uprim(p, args, dbg), approx)

518

519

(* Substitute variables in a [ulambda] term (a body of an inlined function)

520

and perform some more simplifications on integer primitives.

521

Also perform alpha-conversion on let-bound identifiers to avoid

522

clashes with locally-generated identifiers, and refresh raise counts

523

in order to avoid clashes with inlined code from other modules.

524

The variables must not be assigned in the term.

525

This is used to substitute "trivial" arguments for parameters

526

during inline expansion, and also for the translation of let rec

527

over functions. *)

528

529

let approx_ulam = function

530

Uconst c -> Value_const c

531

| _ -> Value_unknown

532

533

let find_action idxs acts tag =

534

if 0 <= tag && tag < Array.length idxs then begin

535

let idx = idxs.(tag) in

536

assert(0 <= idx && idx < Array.length acts);

537

Some acts.(idx)

538

end else

539

(* Can this happen? *)

540

None

541

542

let subst_debuginfo loc dbg =

543

if !Clflags.debug then

544

Debuginfo.inline loc dbg

545

else

546

dbg

547

548

let rec substitute loc ((backend, fpc) as st) sb rn ulam =

549

match ulam with

550

Uvar v ->

551

begin try V.Map.find v sb with Not_found -> ulam end

552

| Uconst _ -> ulam

553

| Udirect_apply(lbl, args, dbg) ->

554

let dbg = subst_debuginfo loc dbg in

555

Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg)

556

| Ugeneric_apply(fn, args, dbg) ->

557

let dbg = subst_debuginfo loc dbg in

558

Ugeneric_apply(substitute loc st sb rn fn,

559

List.map (substitute loc st sb rn) args, dbg)

560

| Uclosure(defs, env) ->

561

(* Question: should we rename function labels as well? Otherwise,

562

there is a risk that function labels are not globally unique.

563

This should not happen in the current system because:

564

- Inlined function bodies contain no Uclosure nodes

565

(cf. function [lambda_smaller])

566

- When we substitute offsets for idents bound by let rec

567

in [close], case [Lletrec], we discard the original

568

let rec body and use only the substituted term. *)

569

Uclosure(defs, List.map (substitute loc st sb rn) env)

570

| Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs)

571

| Ulet(str, kind, id, u1, u2) ->

572

let id' = VP.rename id in

573

Ulet(str, kind, id', substitute loc st sb rn u1,

574

substitute loc st

575

(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)

576

| Uphantom_let _ -> no_phantom_lets ()

577

| Uletrec(bindings, body) ->

578

let bindings1 =

579

List.map (fun (id, rhs) ->

580

(VP.var id, VP.rename id, rhs)) bindings

581

in

582

let sb' =

583

List.fold_right (fun (id, id', _) s ->

584

V.Map.add id (Uvar (VP.var id')) s)

585

bindings1 sb

586

in

587

Uletrec(

588

List.map

589

(fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs))

590

bindings1,

591

substitute loc st sb' rn body)

592

| Uprim(p, args, dbg) ->

593

let sargs = List.map (substitute loc st sb rn) args in

594

let dbg = subst_debuginfo loc dbg in

595

let (res, _) =

596

simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in

597

res

598

| Uswitch(arg, sw, dbg) ->

599

let sarg = substitute loc st sb rn arg in

600

let action =

601

(* Unfortunately, we cannot easily deal with the

602

case of a constructed block (makeblock) bound to a local

603

identifier. This would require to keep track of

604

local let bindings (at least their approximations)

605

in this substitute function.

606

*)

607

match sarg with

608

| Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) ->

609

find_action sw.us_index_blocks sw.us_actions_blocks tag

610

| Uconst (Uconst_ptr tag) ->

611

find_action sw.us_index_consts sw.us_actions_consts tag

612

| _ -> None

613

in

614

begin match action with

615

| Some u -> substitute loc st sb rn u

616

| None ->

617

Uswitch(sarg,

618

{ sw with

619

us_actions_consts =

620

Array.map (substitute loc st sb rn) sw.us_actions_consts;

621

us_actions_blocks =

622

Array.map (substitute loc st sb rn) sw.us_actions_blocks;

623

},

624

dbg)

625

end

626

| Ustringswitch(arg,sw,d) ->

627

Ustringswitch

628

(substitute loc st sb rn arg,

629

List.map (fun (s,act) -> s,substitute loc st sb rn act) sw,

630

Option.map (substitute loc st sb rn) d)

631

| Ustaticfail (nfail, args) ->

632

let nfail =

633

match rn with

634

| Some rn ->

635

begin try

636

Int.Map.find nfail rn

637

with Not_found ->

638

fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail

639

end

640

| None -> nfail in

641

Ustaticfail (nfail, List.map (substitute loc st sb rn) args)

642

| Ucatch(nfail, ids, u1, u2) ->

643

let nfail, rn =

644

match rn with

645

| Some rn ->

646

let new_nfail = next_raise_count () in

647

new_nfail, Some (Int.Map.add nfail new_nfail rn)

648

| None -> nfail, rn in

649

let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in

650

let sb' =

651

List.fold_right2

652

(fun (id, _) (id', _) s ->

653

V.Map.add (VP.var id) (Uvar (VP.var id')) s

654

)

655

ids ids' sb

656

in

657

Ucatch(nfail, ids', substitute loc st sb rn u1,

658

substitute loc st sb' rn u2)

659

| Utrywith(u1, id, u2) ->

660

let id' = VP.rename id in

661

Utrywith(substitute loc st sb rn u1, id',

662

substitute loc st

663

(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)

664

| Uifthenelse(u1, u2, u3) ->

665

begin match substitute loc st sb rn u1 with

666

Uconst (Uconst_ptr n) ->

667

if n <> 0 then

668

substitute loc st sb rn u2

669

else

670

substitute loc st sb rn u3

671

| Uprim(P.Pmakeblock _, _, _) ->

672

substitute loc st sb rn u2

673

| su1 ->

674

Uifthenelse(su1, substitute loc st sb rn u2,

675

substitute loc st sb rn u3)

676

end

677

| Usequence(u1, u2) ->

678

Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2)

679

| Uwhile(u1, u2) ->

680

Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2)

681

| Ufor(id, u1, u2, dir, u3) ->

682

let id' = VP.rename id in

683

Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir,

684

substitute loc st

685

(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3)

686

| Uassign(id, u) ->

687

let id' =

688

try

689

match V.Map.find id sb with Uvar i -> i | _ -> assert false

690

with Not_found ->

691

id in

692

Uassign(id', substitute loc st sb rn u)

693

| Usend(k, u1, u2, ul, dbg) ->

694

let dbg = subst_debuginfo loc dbg in

695

Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2,

696

List.map (substitute loc st sb rn) ul, dbg)

697

| Uunreachable ->

698

Uunreachable

699

700

(* Perform an inline expansion *)

701

702

let is_simple_argument = function

703

| Uvar _ | Uconst _ -> true

704

| _ -> false

705

706

let no_effects = function

707

| Uclosure _ -> true

708

| u -> is_pure u

709

710

let rec bind_params_rec loc fpc subst params args body =

711

match (params, args) with

712

([], []) -> substitute loc fpc subst (Some Int.Map.empty) body

713

| (p1 :: pl, a1 :: al) ->

714

if is_simple_argument a1 then

715

bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst)

716

pl al body

717

else begin

718

let p1' = VP.rename p1 in

719

let u1, u2 =

720

match VP.name p1, a1 with

721

| "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) ->

722

a, Uprim(P.Pmakeblock(0, Immutable, kind),

723

[Uvar (VP.var p1')], dbg)

724

| _ ->

725

a1, Uvar (VP.var p1')

726

in

727

let body' =

728

bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst)

729

pl al body in

730

if occurs_var (VP.var p1) body then

731

Ulet(Immutable, Pgenval, p1', u1, body')

732

else if no_effects a1 then body'

733

else Usequence(a1, body')

734

end

735

| (_, _) -> assert false

736

737

let bind_params loc fpc params args body =

738

(* Reverse parameters and arguments to preserve right-to-left

739

evaluation order (PR#2910). *)

740

bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body

741

742

(* Check if a lambda term is ``pure'',

743

that is without side-effects *and* not containing function definitions *)

744

745

let warning_if_forced_inline ~loc ~attribute warning =

746

if attribute = Always_inline then

747

Location.prerr_warning loc

748

(Warnings.Inlining_impossible warning)

749

750

(* Generate a direct application *)

751

752

let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute =

753

let app_args =

754

if fundesc.fun_closed then uargs else uargs @ [ufunct] in

755

let app =

756

match fundesc.fun_inline, attribute with

757

| _, Never_inline | None, _ ->

758

let dbg = Debuginfo.from_location loc in

759

warning_if_forced_inline ~loc ~attribute

760

"Function information unavailable";

761

Udirect_apply(fundesc.fun_label, app_args, dbg)

762

| Some(params, body), _ ->

763

bind_params loc (backend, fundesc.fun_float_const_prop) params app_args

764

body

765

in

766

(* If ufunct can contain side-effects or function definitions,

767

we must make sure that it is evaluated exactly once.

768

If the function is not closed, we evaluate ufunct as part of the

769

arguments.

770

If the function is closed, we force the evaluation of ufunct first. *)

771

if not fundesc.fun_closed || is_pure ufunct

772

then app

773

else Usequence(ufunct, app)

774

775

(* Add [Value_integer] or [Value_constptr] info to the approximation

776

of an application *)

777

778

let strengthen_approx appl approx =

779

match approx_ulam appl with

780

(Value_const _) as intapprox ->

781

intapprox

782

| _ -> approx

783

784

(* If a term has approximation Value_integer or Value_constptr and is pure,

785

replace it by an integer constant *)

786

787

let check_constant_result ulam approx =

788

match approx with

789

Value_const c when is_pure ulam -> make_const c

790

| Value_global_field (id, i) when is_pure ulam ->

791

begin match ulam with

792

| Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx)

793

| _ ->

794

let glb =

795

Uprim(P.Pread_symbol id, [], Debuginfo.none)

796

in

797

Uprim(P.Pfield i, [glb], Debuginfo.none), approx

798

end

799

| _ -> (ulam, approx)

800

801

(* Evaluate an expression with known value for its side effects only,

802

or discard it if it's pure *)

803

804

let sequence_constant_expr ulam1 (ulam2, approx2 as res2) =

805

if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2)

806

807

(* Maintain the approximation of the global structure being defined *)

808

809

let global_approx = ref([||] : value_approximation array)

810

811

(* Maintain the nesting depth for functions *)

812

813

let function_nesting_depth = ref 0

814

let excessive_function_nesting_depth = 5

815

816

(* Uncurry an expression and explicitate closures.

817

Also return the approximation of the expression.

818

The approximation environment [fenv] maps idents to approximations.

819

Idents not bound in [fenv] approximate to [Value_unknown].

820

The closure environment [cenv] maps idents to [ulambda] terms.

821

It is used to substitute environment accesses for free identifiers. *)

822

823

exception NotClosed

824

825

type env = {

826

backend : (module Backend_intf.S);

827

cenv : ulambda V.Map.t;

828

fenv : value_approximation V.Map.t;

829

}

830

831

let close_approx_var { fenv; cenv } id =

832

let approx = try V.Map.find id fenv with Not_found -> Value_unknown in

833

match approx with

834

Value_const c -> make_const c

835

| approx ->

836

let subst = try V.Map.find id cenv with Not_found -> Uvar id in

837

(subst, approx)

838

839

let close_var env id =

840

let (ulam, _app) = close_approx_var env id in ulam

841

842

let rec close ({ backend; fenv; cenv } as env) lam =

843

let module B = (val backend : Backend_intf.S) in

844

match lam with

845

| Lvar id ->

846

close_approx_var env id

847

| Lconst cst ->

848

let str ?(shared = true) cst =

849

let name =

850

Compilenv.new_structured_constant cst ~shared

851

in

852

Uconst_ref (name, Some cst)

853

in

854

let rec transl = function

855

| Const_base(Const_int n) -> Uconst_int n

856

| Const_base(Const_char c) -> Uconst_int (Char.code c)

857

| Const_pointer n -> Uconst_ptr n

858

| Const_block (tag, fields) ->

859

str (Uconst_block (tag, List.map transl fields))

860

| Const_float_array sl ->

861

(* constant float arrays are really immutable *)

862

str (Uconst_float_array (List.map float_of_string sl))

863

| Const_immstring s ->

864

str (Uconst_string s)

865

| Const_base (Const_string (s, _)) ->

866

(* Strings (even literal ones) must be assumed to be mutable...

867

except when OCaml has been configured with

868

-safe-string. Passing -safe-string at compilation

869

time is not enough, since the unit could be linked

870

with another one compiled without -safe-string, and

871

that one could modify our string literal. *)

872

str ~shared:Config.safe_string (Uconst_string s)

873

| Const_base(Const_float x) -> str (Uconst_float (float_of_string x))

874

| Const_base(Const_int32 x) -> str (Uconst_int32 x)

875

| Const_base(Const_int64 x) -> str (Uconst_int64 x)

876

| Const_base(Const_nativeint x) -> str (Uconst_nativeint x)

877

in

878

make_const (transl cst)

879

| Lfunction _ as funct ->

880

close_one_function env (Ident.create_local "fun") funct

881

882

(* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]

883

when fun_arity > nargs *)

884

| Lapply{ap_func = funct; ap_args = args; ap_loc = loc;

885

ap_inlined = attribute} ->

886

let nargs = List.length args in

887

begin match (close env funct, close_list env args) with

888

((ufunct, Value_closure(fundesc, approx_res)),

889

[Uprim(P.Pmakeblock _, uargs, _)])

890

when List.length uargs = - fundesc.fun_arity ->

891

let app =

892

direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in

893

(app, strengthen_approx app approx_res)

894

| ((ufunct, Value_closure(fundesc, approx_res)), uargs)

895

when nargs = fundesc.fun_arity ->

896

let app =

897

direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in

898

(app, strengthen_approx app approx_res)

899

900

| ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)

901

when nargs < fundesc.fun_arity ->

902

let first_args = List.map (fun arg ->

903

(V.create_local "arg", arg) ) uargs in

904

let final_args =

905

Array.to_list (Array.init (fundesc.fun_arity - nargs)

906

(fun _ -> V.create_local "arg")) in

907

let rec iter args body =

908

match args with

909

[] -> body

910

| (arg1, arg2) :: args ->

911

iter args

912

(Ulet (Immutable, Pgenval, VP.create arg1, arg2, body))

913

in

914

let internal_args =

915

(List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)

916

@ (List.map (fun arg -> Lvar arg ) final_args)

917

in

918

let funct_var = V.create_local "funct" in

919

let fenv = V.Map.add funct_var fapprox fenv in

920

let (new_fun, approx) = close { backend; fenv; cenv }

921

(Lfunction{

922

kind = Curried;

923

return = Pgenval;

924

params = List.map (fun v -> v, Pgenval) final_args;

925

body = Lapply{ap_should_be_tailcall=false;

926

ap_loc=loc;

927

ap_func=(Lvar funct_var);

928

ap_args=internal_args;

929

ap_inlined=Default_inline;

930

ap_specialised=Default_specialise};

931

loc;

932

attr = default_function_attribute})

933

in

934

let new_fun =

935

iter first_args

936

(Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun))

937

in

938

warning_if_forced_inline ~loc ~attribute "Partial application";

939

(new_fun, approx)

940

941

| ((ufunct, Value_closure(fundesc, _approx_res)), uargs)

942

when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->

943

let args = List.map (fun arg -> V.create_local "arg", arg) uargs in

944

let (first_args, rem_args) = split_list fundesc.fun_arity args in

945

let first_args = List.map (fun (id, _) -> Uvar id) first_args in

946

let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in

947

let dbg = Debuginfo.from_location loc in

948

warning_if_forced_inline ~loc ~attribute "Over-application";

949

let body =

950

Ugeneric_apply(direct_apply ~backend ~loc ~attribute

951

fundesc ufunct first_args,

952

rem_args, dbg)

953

in

954

let result =

955

List.fold_left (fun body (id, defining_expr) ->

956

Ulet (Immutable, Pgenval, VP.create id, defining_expr, body))

957

body

958

args

959

in

960

result, Value_unknown

961

| ((ufunct, _), uargs) ->

962

let dbg = Debuginfo.from_location loc in

963

warning_if_forced_inline ~loc ~attribute "Unknown function";

964

(Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)

965

end

966

| Lsend(kind, met, obj, args, loc) ->

967

let (umet, _) = close env met in

968

let (uobj, _) = close env obj in

969

let dbg = Debuginfo.from_location loc in

970

(Usend(kind, umet, uobj, close_list env args, dbg),

971

Value_unknown)

972

| Llet(str, kind, id, lam, body) ->

973

let (ulam, alam) = close_named env id lam in

974

begin match (str, alam) with

975

(Variable, _) ->

976

let (ubody, abody) = close env body in

977

(Ulet(Mutable, kind, VP.create id, ulam, ubody), abody)

978

| (_, Value_const _)

979

when str = Alias || is_pure ulam ->

980

close { backend; fenv = (V.Map.add id alam fenv); cenv } body

981

| (_, _) ->

982

let (ubody, abody) =

983

close { backend; fenv = (V.Map.add id alam fenv); cenv } body

984

in

985

(Ulet(Immutable, kind, VP.create id, ulam, ubody), abody)

986

end

987

| Lletrec(defs, body) ->

988

if List.for_all

989

(function (_id, Lfunction _) -> true | _ -> false)

990

defs

991

then begin

992

(* Simple case: only function definitions *)

993

let (clos, infos) = close_functions env defs in

994

let clos_ident = V.create_local "clos" in

995

let fenv_body =

996

List.fold_right

997

(fun (id, _pos, approx) fenv -> V.Map.add id approx fenv)

998

infos fenv in

999

let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in

1000

let sb =

1001

List.fold_right

1002

(fun (id, pos, _approx) sb ->

1003

V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb)

1004

infos V.Map.empty in

1005

(Ulet(Immutable, Pgenval, VP.create clos_ident, clos,

1006

substitute Location.none (backend, !Clflags.float_const_prop) sb

1007

None ubody),

1008

approx)

1009

end else begin

1010

(* General case: recursive definition of values *)

1011

let rec clos_defs = function

1012

[] -> ([], fenv)

1013

| (id, lam) :: rem ->

1014

let (udefs, fenv_body) = clos_defs rem in

1015

let (ulam, approx) = close_named env id lam in

1016

((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in

1017

let (udefs, fenv_body) = clos_defs defs in

1018

let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in

1019

(Uletrec(udefs, ubody), approx)

1020

end

1021

(* Compile-time constants *)

1022

| Lprim(Pctconst c, [arg], _loc) ->

1023

let cst, approx =

1024

match c with

1025

| Big_endian -> make_const_bool B.big_endian

1026

| Word_size -> make_const_int (8*B.size_int)

1027

| Int_size -> make_const_int (8*B.size_int - 1)

1028

| Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 )

1029

| Ostype_unix -> make_const_bool (Sys.os_type = "Unix")

1030

| Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")

1031

| Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")

1032

| Backend_type ->

1033

make_const_ptr 0 (* tag 0 is the same as Native here *)

1034

in

1035

let arg, _approx = close env arg in

1036

let id = Ident.create_local "dummy" in

1037

Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx

1038

| Lprim(Pignore, [arg], _loc) ->

1039

let expr, approx = make_const_ptr 0 in

1040

Usequence(fst (close env arg), expr), approx

1041

| Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->

1042

close env arg

1043

| Lprim(Pdirapply,[funct;arg], loc)

1044

| Lprim(Prevapply,[arg;funct], loc) ->

1045

close env (Lapply{ap_should_be_tailcall=false;

1046

ap_loc=loc;

1047

ap_func=funct;

1048

ap_args=[arg];

1049

ap_inlined=Default_inline;

1050

ap_specialised=Default_specialise})

1051

| Lprim(Pgetglobal id, [], loc) ->

1052

let dbg = Debuginfo.from_location loc in

1053

check_constant_result (getglobal dbg id)

1054

(Compilenv.global_approx id)

1055

| Lprim(Pfield n, [lam], loc) ->

1056

let (ulam, approx) = close env lam in

1057

let dbg = Debuginfo.from_location loc in

1058

check_constant_result (Uprim(P.Pfield n, [ulam], dbg))

1059

(field_approx n approx)

1060

| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->

1061

let (ulam, approx) = close env lam in

1062

if approx <> Value_unknown then

1063

(!global_approx).(n) <- approx;

1064

let dbg = Debuginfo.from_location loc in

1065

(Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),

1066

Value_unknown)

1067

| Lprim(Praise k, [arg], loc) ->

1068

let (ulam, _approx) = close env arg in

1069

let dbg = Debuginfo.from_location loc in

1070

(Uprim(P.Praise k, [ulam], dbg),

1071

Value_unknown)

1072

| Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, []))

1073

| Lprim(p, args, loc) ->

1074

let p = Convert_primitives.convert p in

1075

let dbg = Debuginfo.from_location loc in

1076

simplif_prim ~backend !Clflags.float_const_prop

1077

p (close_list_approx env args) dbg

1078

| Lswitch(arg, sw, dbg) ->

1079

let fn fail =

1080

let (uarg, _) = close env arg in

1081

let const_index, const_actions, fconst =

1082

close_switch env sw.sw_consts sw.sw_numconsts fail

1083

and block_index, block_actions, fblock =

1084

close_switch env sw.sw_blocks sw.sw_numblocks fail in

1085

let ulam =

1086

Uswitch

1087

(uarg,

1088

{us_index_consts = const_index;

1089

us_actions_consts = const_actions;

1090

us_index_blocks = block_index;

1091

us_actions_blocks = block_actions},

1092

Debuginfo.from_location dbg)

1093

in

1094

(fconst (fblock ulam),Value_unknown) in

1095

(* NB: failaction might get copied, thus it should be some Lstaticraise *)

1096

let fail = sw.sw_failaction in

1097

begin match fail with

1098

| None|Some (Lstaticraise (_,_)) -> fn fail

1099

| Some lamfail ->

1100

if

1101

(sw.sw_numconsts - List.length sw.sw_consts) +

1102

(sw.sw_numblocks - List.length sw.sw_blocks) > 1

1103

then

1104

let i = next_raise_count () in

1105

let ubody,_ = fn (Some (Lstaticraise (i,[])))

1106

and uhandler,_ = close env lamfail in

1107

Ucatch (i,[],ubody,uhandler),Value_unknown

1108

else fn fail

1109

end

1110

| Lstringswitch(arg,sw,d,_) ->

1111

let uarg,_ = close env arg in

1112

let usw =

1113

List.map

1114

(fun (s,act) ->

1115

let uact,_ = close env act in

1116

s,uact)

1117

sw in

1118

let ud =

1119

Option.map

1120

(fun d ->

1121

let ud,_ = close env d in

1122

ud) d in

1123

Ustringswitch (uarg,usw,ud),Value_unknown

1124

| Lstaticraise (i, args) ->

1125

(Ustaticfail (i, close_list env args), Value_unknown)

1126

| Lstaticcatch(body, (i, vars), handler) ->

1127

let (ubody, _) = close env body in

1128

let (uhandler, _) = close env handler in

1129

let vars = List.map (fun (var, k) -> VP.create var, k) vars in

1130

(Ucatch(i, vars, ubody, uhandler), Value_unknown)

1131

| Ltrywith(body, id, handler) ->

1132

let (ubody, _) = close env body in

1133

let (uhandler, _) = close env handler in

1134

(Utrywith(ubody, VP.create id, uhandler), Value_unknown)

1135

| Lifthenelse(arg, ifso, ifnot) ->

1136

begin match close env arg with

1137

(uarg, Value_const (Uconst_ptr n)) ->

1138

sequence_constant_expr uarg

1139

(close env (if n = 0 then ifnot else ifso))

1140

| (uarg, _ ) ->

1141

let (uifso, _) = close env ifso in

1142

let (uifnot, _) = close env ifnot in

1143

(Uifthenelse(uarg, uifso, uifnot), Value_unknown)

1144

end

1145

| Lsequence(lam1, lam2) ->

1146

let (ulam1, _) = close env lam1 in

1147

let (ulam2, approx) = close env lam2 in

1148

(Usequence(ulam1, ulam2), approx)

1149

| Lwhile(cond, body) ->

1150

let (ucond, _) = close env cond in

1151

let (ubody, _) = close env body in

1152

(Uwhile(ucond, ubody), Value_unknown)

1153

| Lfor(id, lo, hi, dir, body) ->

1154

let (ulo, _) = close env lo in

1155

let (uhi, _) = close env hi in

1156

let (ubody, _) = close env body in

1157

(Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown)

1158

| Lassign(id, lam) ->

1159

let (ulam, _) = close env lam in

1160

(Uassign(id, ulam), Value_unknown)

1161

| Levent(lam, _) ->

1162

close env lam

1163

| Lifused _ ->

1164

assert false

1165

1166

and close_list env = function

1167

[] -> []

1168

| lam :: rem ->

1169

let (ulam, _) = close env lam in

1170

ulam :: close_list env rem

1171

1172

and close_list_approx env = function

1173

[] -> ([], [])

1174

| lam :: rem ->

1175

let (ulam, approx) = close env lam in

1176

let (ulams, approxs) = close_list_approx env rem in

1177

(ulam :: ulams, approx :: approxs)

1178

1179

and close_named env id = function

1180

Lfunction _ as funct ->

1181

close_one_function env id funct

1182

| lam ->

1183

close env lam

1184

1185

(* Build a shared closure for a set of mutually recursive functions *)

1186

1187

and close_functions { backend; fenv; cenv } fun_defs =

1188

let fun_defs =

1189

List.flatten

1190

(List.map

1191

(function

1192

| (id, Lfunction{kind; params; return; body; attr; loc}) ->

1193

Simplif.split_default_wrapper ~id ~kind ~params

1194

~body ~attr ~loc ~return

1195

| _ -> assert false

1196

)

1197

fun_defs)

1198

in

1199

let inline_attribute = match fun_defs with

1200

| [_, Lfunction{attr = { inline; }}] -> inline

1201

| _ -> Default_inline (* recursive functions can't be inlined *)

1202

in

1203

(* Update and check nesting depth *)

1204

incr function_nesting_depth;

1205

let initially_closed =

1206

!function_nesting_depth < excessive_function_nesting_depth in

1207

(* Determine the free variables of the functions *)

1208

let fv =

1209

V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in

1210

(* Build the function descriptors for the functions.

1211

Initially all functions are assumed not to need their environment

1212

parameter. *)

1213

let uncurried_defs =

1214

List.map

1215

(function

1216

(id, Lfunction{kind; params; return; body; loc}) ->

1217

let label = Compilenv.make_symbol (Some (V.unique_name id)) in

1218

let arity = List.length params in

1219

let fundesc =

1220

{fun_label = label;

1221

fun_arity = (if kind = Tupled then -arity else arity);

1222

fun_closed = initially_closed;

1223

fun_inline = None;

1224

fun_float_const_prop = !Clflags.float_const_prop } in

1225

let dbg = Debuginfo.from_location loc in

1226

(id, params, return, body, fundesc, dbg)

1227

| (_, _) -> fatal_error "Closure.close_functions")

1228

fun_defs in

1229

(* Build an approximate fenv for compiling the functions *)

1230

let fenv_rec =

1231

List.fold_right

1232

(fun (id, _params, _return, _body, fundesc, _dbg) fenv ->

1233

V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv)

1234

uncurried_defs fenv in

1235

(* Determine the offsets of each function's closure in the shared block *)

1236

let env_pos = ref (-1) in

1237

let clos_offsets =

1238

List.map

1239

(fun (_id, _params, _return, _body, fundesc, _dbg) ->

1240

let pos = !env_pos + 1 in

1241

env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);

1242

pos)

1243

uncurried_defs in

1244

let fv_pos = !env_pos in

1245

(* This reference will be set to false if the hypothesis that a function

1246

does not use its environment parameter is invalidated. *)

1247

let useless_env = ref initially_closed in

1248

(* Translate each function definition *)

1249

let clos_fundef (id, params, return, body, fundesc, dbg) env_pos =

1250

let env_param = V.create_local "env" in

1251

let cenv_fv =

1252

build_closure_env env_param (fv_pos - env_pos) fv in

1253

let cenv_body =

1254

List.fold_right2

1255

(fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->

1256

V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)

1257

uncurried_defs clos_offsets cenv_fv in

1258

let (ubody, approx) =

1259

close { backend; fenv = fenv_rec; cenv = cenv_body } body

1260

in

1261

if !useless_env && occurs_var env_param ubody then raise NotClosed;

1262

let fun_params =

1263

if !useless_env

1264

then params

1265

else params @ [env_param, Pgenval]

1266

in

1267

let f =

1268

{

1269

label = fundesc.fun_label;

1270

arity = fundesc.fun_arity;

1271

params = List.map (fun (var, kind) -> VP.create var, kind) fun_params;

1272

return;

1273

body = ubody;

1274

dbg;

1275

env = Some env_param;

1276

}

1277

in

1278

(* give more chance of function with default parameters (i.e.

1279

their wrapper functions) to be inlined *)

1280

let n =

1281

List.fold_left

1282

(fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1)

1283

0

1284

fun_params

1285

in

1286

let threshold =

1287

match inline_attribute with

1288

| Default_inline ->

1289

let inline_threshold =

1290

Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold

1291

in

1292

let magic_scale_constant = 8. in

1293

int_of_float (inline_threshold *. magic_scale_constant) + n

1294

| Always_inline -> max_int

1295

| Never_inline -> min_int

1296

| Unroll _ -> assert false

1297

in

1298

let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in

1299

if lambda_smaller ubody threshold

1300

then fundesc.fun_inline <- Some(fun_params, ubody);

1301

1302

(f, (id, env_pos, Value_closure(fundesc, approx))) in

1303

(* Translate all function definitions. *)

1304

let clos_info_list =

1305

if initially_closed then begin

1306

let snap = Compilenv.snapshot () in

1307

try List.map2 clos_fundef uncurried_defs clos_offsets

1308

with NotClosed ->

1309

(* If the hypothesis that the environment parameters are useless has been

1310

invalidated, then set [fun_closed] to false in all descriptions and

1311

recompile *)

1312

Compilenv.backtrack snap; (* PR#6337 *)

1313

List.iter

1314

(fun (_id, _params, _return, _body, fundesc, _dbg) ->

1315

fundesc.fun_closed <- false;

1316

fundesc.fun_inline <- None;

1317

)

1318

uncurried_defs;

1319

useless_env := false;

1320

List.map2 clos_fundef uncurried_defs clos_offsets

1321

end else

1322

(* Excessive closure nesting: assume environment parameter is used *)

1323

List.map2 clos_fundef uncurried_defs clos_offsets

1324

in

1325

(* Update nesting depth *)

1326

decr function_nesting_depth;

1327

(* Return the Uclosure node and the list of all identifiers defined,

1328

with offsets and approximations. *)

1329

let (clos, infos) = List.split clos_info_list in

1330

let fv = if !useless_env then [] else fv in

1331

(Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos)

1332

1333

(* Same, for one non-recursive function *)

1334

1335

and close_one_function env id funct =

1336

match close_functions env [id, funct] with

1337

| (clos, (i, _, approx) :: _) when id = i -> (clos, approx)

1338

| _ -> fatal_error "Closure.close_one_function"

1339

1340

(* Close a switch *)

1341

1342

and close_switch env cases num_keys default =

1343

let ncases = List.length cases in

1344

let index = Array.make num_keys 0

1345

and store = Storer.mk_store () in

1346

1347

(* First default case *)

1348

begin match default with

1349

| Some def when ncases < num_keys ->

1350

assert (store.act_store () def = 0)

1351

| _ -> ()

1352

end ;

1353

(* Then all other cases *)

1354

List.iter

1355

(fun (key,lam) ->

1356

index.(key) <- store.act_store () lam)

1357

cases ;

1358

1359

(* Explicit sharing with catch/exit, as switcher compilation may

1360

later unshare *)

1361

let acts = store.act_get_shared () in

1362

let hs = ref (fun e -> e) in

1363

1364

(* Compile actions *)

1365

let actions =

1366

Array.map

1367

(function

1368

| Single lam|Shared (Lstaticraise (_,[]) as lam) ->

1369

let ulam,_ = close env lam in

1370

ulam

1371

| Shared lam ->

1372

let ulam,_ = close env lam in

1373

let i = next_raise_count () in

1374

(*

1375

let string_of_lambda e =

1376

Printlambda.lambda Format.str_formatter e ;

1377

Format.flush_str_formatter () in

1378

Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i

1379

(string_of_lambda arg)

1380

(string_of_lambda lam) ;

1381

*)

1382

let ohs = !hs in

1383

hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ;

1384

Ustaticfail (i,[]))

1385

acts in

1386

match actions with

1387

| [| |] -> [| |], [| |], !hs (* May happen when default is None *)

1388

| _ -> index, actions, !hs

1389

1390

1391

(* Collect exported symbols for structured constants *)

1392

1393

let collect_exported_structured_constants a =

1394

let rec approx = function

1395

| Value_closure (fd, a) ->

1396

approx a;

1397

begin match fd.fun_inline with

1398

| Some (_, u) -> ulam u

1399

| None -> ()

1400

end

1401

| Value_tuple a -> Array.iter approx a

1402

| Value_const c -> const c

1403

| Value_unknown | Value_global_field _ -> ()

1404

and const = function

1405

| Uconst_ref (s, (Some c)) ->

1406

Compilenv.add_exported_constant s;

1407

structured_constant c

1408

| Uconst_ref (_s, None) -> assert false (* Cannot be generated *)

1409

| Uconst_int _ | Uconst_ptr _ -> ()

1410

and structured_constant = function

1411

| Uconst_block (_, ul) -> List.iter const ul

1412

| Uconst_float _ | Uconst_int32 _

1413

| Uconst_int64 _ | Uconst_nativeint _

1414

| Uconst_float_array _ | Uconst_string _ -> ()

1415

| Uconst_closure _ -> assert false (* Cannot be generated *)

1416

and ulam = function

1417

| Uvar _ -> ()

1418

| Uconst c -> const c

1419

| Udirect_apply (_, ul, _) -> List.iter ulam ul

1420

| Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul

1421

| Uclosure (fl, ul) ->

1422

List.iter (fun f -> ulam f.body) fl;

1423

List.iter ulam ul

1424

| Uoffset(u, _) -> ulam u

1425

| Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2

1426

| Uphantom_let _ -> no_phantom_lets ()

1427

| Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u

1428

| Uprim (_, ul, _) -> List.iter ulam ul

1429

| Uswitch (u, sl, _dbg) ->

1430

ulam u;

1431

Array.iter ulam sl.us_actions_consts;

1432

Array.iter ulam sl.us_actions_blocks

1433

| Ustringswitch (u,sw,d) ->

1434

ulam u ;

1435

List.iter (fun (_,act) -> ulam act) sw ;

1436

Option.iter ulam d

1437

| Ustaticfail (_, ul) -> List.iter ulam ul

1438

| Ucatch (_, _, u1, u2)

1439

| Utrywith (u1, _, u2)

1440

| Usequence (u1, u2)

1441

| Uwhile (u1, u2) -> ulam u1; ulam u2

1442

| Uifthenelse (u1, u2, u3)

1443

| Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3

1444

| Uassign (_, u) -> ulam u

1445

| Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul

1446

| Uunreachable -> ()

1447

in

1448

approx a

1449

1450

let reset () =

1451

global_approx := [||];

1452

function_nesting_depth := 0

1453

1454

(* The entry point *)

1455

1456

let intro ~backend ~size lam =

1457

reset ();

1458

let id = Compilenv.make_symbol None in

1459

global_approx := Array.init size (fun i -> Value_global_field (id, i));

1460

Compilenv.set_global_approx(Value_tuple !global_approx);

1461

let (ulam, _approx) =

1462

close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam

1463

in

1464

let opaque =

1465

!Clflags.opaque

1466

|| Env.is_imported_opaque (Compilenv.current_unit_name ())

1467

in

1468

if opaque

1469

then Compilenv.set_global_approx(Value_unknown)

1470

else collect_exported_structured_constants (Value_tuple !global_approx);

1471

global_approx := [||];

1472

ulam

1473