heh/compile_sac.ml at master · ashinkarov/heh

Repository navigation

History

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

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

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

* Permission to use, copy, modify, and/or distribute this software for any

* purpose with or without fee is hereby granted, provided that the above

* copyright notice and this permission notice appear in all copies.

* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH

* REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY

* AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,

* INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM

* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE

* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR

* PERFORMANCE OF THIS SOFTWARE.

type sac_type =

| SacInt

| SacBool

type sac_prog =

sac_function list

and sac_function = { name: string;

params: sac_params;

body: sac_stmt list;

comment: string }

and sac_params = (sac_type * string) list

and sac_stmt =

| SacAssign of string * sac_expr

| SacReturn of sac_expr

| SacCond of sac_expr * (sac_stmt list) * (sac_stmt list)

and sac_expr =

| SacFalse

| SacTrue

| SacNum of int

| SacArray of sac_expr list

| SacVar of string

(*| SacBinop of sac_binop * sac_expr * sac_expr *)

| SacFuncall of string * (sac_expr list)

| SacWith of (sac_generator * sac_stmt list * sac_expr) list * sac_wlop

and sac_generator = sac_expr * string * sac_expr

(* Default element, size *)

and sac_wlop =

| SacGenarray of sac_expr * sac_expr

| SacFold of sac_expr * sac_expr

(*and sac_binop =

| SacOpPlus

| SacOpMinus

| SacOpMul

| SacOpDiv*)

(* Helper mk_ functions. *)

let mk_sac_function ?(comment="") name params stmts =

{ name = name; params = params; body = stmts; comment = comment }

(* Print sac program. *)

open Printf

let prind oc n =

for i = 1 to n do

fprintf oc " "

done

let rec print_sep_list ?(sep=", ") oc f args =

match args with

| [] -> ()

| x :: [] -> f x;

| x :: t -> f x; fprintf oc "%s" sep; print_sep_list oc f t

let rec print_sac_expr oc level e =

match e with

| SacTrue ->

fprintf oc "true"

| SacFalse ->

fprintf oc "false"

| SacNum n ->

fprintf oc "%d" n

| SacArray lst ->

fprintf oc "[";

print_sep_list oc (print_sac_expr oc level) lst;

fprintf oc "]"

| SacVar x ->

fprintf oc "%s" x

| SacFuncall (f, args) ->

fprintf oc "%s (" f; print_sep_list oc (print_sac_expr oc level) args; fprintf oc ")"

| SacWith (partlst, with_expr) ->

fprintf oc "with {\n";

List.fold_left (fun () part -> print_wl_part oc (level+1) part) () partlst;

prind oc level; fprintf oc "}: ";

match with_expr with

| SacGenarray (shp, def) ->

fprintf oc "genarray ("; print_sac_expr oc level shp;

fprintf oc ", "; print_sac_expr oc level def;

fprintf oc ")"

| SacFold (func, neut) ->

fprintf oc "fold ("; print_sac_expr oc level func;

fprintf oc ", "; print_sac_expr oc level neut;

fprintf oc ")"

and print_wl_part oc level part =

let gen, stmts, expr = part in

prind oc level; print_gen oc level gen;

fprintf oc "\n";

print_sac_stmts oc level stmts;

prind oc level; fprintf oc ": ";

print_sac_expr oc level expr;

fprintf oc ";\n"

and print_gen oc level gen =

let lb, x, ub = gen in

fprintf oc "("; print_sac_expr oc level lb;

fprintf oc " <= %s < " x;

print_sac_expr oc level ub;

fprintf oc ")"

and print_sac_stmt oc level s =

match s with

| SacAssign (s, e) ->

prind oc level; fprintf oc "%s = " s;

print_sac_expr oc level e; fprintf oc ";\n"

| SacCond (e, stmts1, stmts2) ->

prind oc level;

fprintf oc "if ("; print_sac_expr oc level e; fprintf oc ")\n";

print_sac_stmts oc level stmts1;

prind oc level;

fprintf oc "else\n";

print_sac_stmts oc level stmts2;

| SacReturn (e) ->

prind oc level;

fprintf oc "return ";

print_sac_expr oc level e;

fprintf oc ";\n"

and print_sac_stmts oc level stmts =

prind oc level; fprintf oc "{\n";

List.fold_left (fun () s -> print_sac_stmt oc (level+1) s) () stmts;

prind oc level; fprintf oc "}\n"

let print_sac_params oc (params: sac_params) =

fprintf oc "(";

print_sep_list oc (fun (param: sac_type * string) ->

let t, name = param in

match t with

| SacInt -> fprintf oc "int[*] %s" name

| SacBool -> fprintf oc "bool[*] %s" name)

params;

fprintf oc ")"

let print_sac_fun oc f =

if f.comment <> "" then

fprintf oc "// %s\n" f.comment;

if f.name = "main" then

fprintf oc "int\nmain "

else

fprintf oc "inline int[*]\n%s " f.name

;

print_sac_params oc f.params;

fprintf oc "\n";

print_sac_stmts oc 0 f.body

let print_sac_prog oc p =

List.fold_left (fun () f -> print_sac_fun oc f; fprintf oc "\n\n") () p

let var_count = ref 0

(* Generate a fresh pointer name. *)

let fresh_var_name () =

var_count := !var_count + 1;

Printf.sprintf "x_%d" !var_count

let rec compile_stmts stmts e =

let open Ast in

match e with

| { expr_kind = EFalse } ->

let res_var = fresh_var_name () in

(stmts @ [SacAssign (res_var, SacFalse)], res_var)

| { expr_kind = ETrue } ->

let res_var = fresh_var_name () in

(stmts @ [SacAssign (res_var, SacTrue)], res_var)

| { expr_kind = ENum n } ->

let n = Ordinals.ord_to_nat n in

let res_var = fresh_var_name () in

(stmts @ [SacAssign (res_var, SacNum n)], res_var)

| { expr_kind = EVar (x) } ->

(stmts, x)

| { expr_kind = EArray (lst) } ->

let stmts_lst, vars =

List.split @@ List.map (compile_stmts []) lst in

let res_var = fresh_var_name () in

let res_arr = SacArray (List.map (fun x -> SacVar x) vars) in

(stmts @ List.flatten stmts_lst @ [SacAssign (res_var, res_arr)],

res_var)

| { expr_kind = EBinOp (op, e1, e2) } ->

let stmts, var1 = compile_stmts stmts e1 in

let stmts, var2 = compile_stmts stmts e2 in

let res_var = fresh_var_name () in

let opname =

match op with

| OpPlus -> "_add_SxS_"

| OpMinus -> "_sub_SxS_"

| OpDiv -> "_div_SxS_"

| OpMod -> "_mod_SxS_"

| OpMult -> "_mul_SxS_"

| OpLt -> "_lt_SxS_"

| OpLe -> "_le_SxS_"

| OpGt -> "_gt_SxS_"

| OpGe -> "_ge_SxS_"

| OpEq -> "_eq_SxS_"

| OpNe -> "_ne_SxS_"

let funcall = SacFuncall (opname, [SacVar var1; SacVar var2]) in

(stmts @ [SacAssign (res_var, funcall)], res_var)

| { expr_kind = EUnary (op, e1) } ->

let stmts, var1 = compile_stmts stmts e1 in

let opname =

match op with

| OpShape -> "_shape_A_"

| OpIsLim -> "is_limit_ordinal" in

let res_var = fresh_var_name () in

let funcall = SacFuncall (opname, [SacVar var1]) in

(stmts @ [SacAssign (res_var, funcall)], res_var)

| { expr_kind = ELambda (x, e) } ->

failwith "Lambdas are not supported in sac, they should have been lifted."

| { expr_kind = EApply (e1, e2) } ->

let res_var = fresh_var_name () in

(* XXX we assume that there are no higher-order

* functions anymore. If there are, we are in

* trouble.

let fargs = Lifting.flatten_apply e in

let argstmts_vars = List.map (compile_stmts []) fargs in

let argstmts, vars = List.split argstmts_vars in

let argstmts = List.flatten argstmts in

let fname = List.hd vars in

let fargs = List.map (fun x -> SacVar x) @@ List.tl vars in

let funcall = SacFuncall (fname, fargs) in

(stmts @ argstmts @ [SacAssign (res_var, funcall)], res_var)

| { expr_kind = ESel (e1, e2) } ->

let stmts, var1 = compile_stmts stmts e1 in

let stmts, var2 = compile_stmts stmts e2 in

let res_var = fresh_var_name () in

let funcall = SacFuncall ("_sel_VxA_", [SacVar var2; SacVar var1]) in

(stmts @ [SacAssign (res_var, funcall)], res_var)

| { expr_kind = ECond (e1, e2, e3) } ->

let stmts1, var1 = compile_stmts stmts e1 in

let stmts2, var2 = compile_stmts [] e2 in

let stmts3, var3 = compile_stmts [] e3 in

let res_var = fresh_var_name () in

let stmts2 = stmts2 @ [SacAssign (res_var, SacVar var2)] in

let stmts3 = stmts3 @ [SacAssign (res_var, SacVar var3)] in

(stmts1 @ [SacCond (SacVar var1, stmts2, stmts3)], res_var)

| { expr_kind = ELetRec (s, e1, e2) } ->

let stmts1, var1 = compile_stmts [] e1 in

let stmts1 = stmts1 @ [SacAssign (s, SacVar var1)] in

let stmts2, var2 = compile_stmts [] e2 in

(stmts @ stmts1 @ stmts2, var2)

| { expr_kind = EImap (e_out, e_in, ge_lst) } ->

let stmts, var1 = compile_stmts stmts e_out in

let stmts, var2 = compile_stmts stmts e_in in

(* Concat shape vectors into shp_var *)

(*let shp_var = fresh_var_name () in

let funcall = SacFuncall ("vec_concat", [SacVar var1; SacVar var2]) in

let stmts = stmts @ [SacAssign (shp_var, funcall)] in*)

(* Emit code for all the generator expressions. *)

let gen_code = List.map

(fun ge ->

let gen, e = ge in

let lb, x, ub = gen in

let stmts, var_lb = compile_stmts [] lb in

let stmts, var_ub = compile_stmts stmts ub in

(stmts, (var_lb, x, var_ub, e)))

ge_lst in

let stmts_lst_gens, var_gen_expr_lst = List.split gen_code in

let stmts = stmts @ List.flatten stmts_lst_gens in

let wl_parts = List.map

(fun var_gen_expr ->

let var_lb, x, var_ub, e = var_gen_expr in

let stmts, res_var = compile_stmts [] e in

let sac_gen = (SacVar var_lb, x, SacVar var_ub) in

(sac_gen, stmts, SacVar res_var))

var_gen_expr_lst in

let res_var = fresh_var_name () in

let wl_kind = SacGenarray (SacVar var1, SacFuncall ("zeroes", [SacVar var2])) in

let wl = SacWith (wl_parts, wl_kind) in

(stmts @ [SacAssign (res_var, wl)], res_var)

| { expr_kind = EReduce (e_fun, e_neut, e_arg) } ->

let stmts, fname = compile_stmts stmts e_fun in

let stmts, neut = compile_stmts stmts e_neut in

let stmts, arg = compile_stmts stmts e_arg in

(* get the shape of the argument *)

let shape_var = fresh_var_name () in

let shape_funcall = SacFuncall ("_shape_A_", [SacVar arg]) in

let stmts = stmts @ [SacAssign (shape_var, shape_funcall)] in

(* get the zero element of the argument *)

let zero_var = fresh_var_name () in

let zero_funcall = SacFuncall ("zero_vec", [SacVar shape_var]) in

let stmts = stmts @ [SacAssign (zero_var, zero_funcall)] in

(* build a with-loop with reduce expression *)

let res_var = fresh_var_name () in

let wl_kind = SacFold (SacVar fname, SacVar neut) in

let iv = fresh_var_name () in

let sel_var = fresh_var_name () in

let wl_parts = [((SacVar zero_var, iv, SacVar shape_var),

[SacAssign (sel_var, SacFuncall ("_sel_VxA_", [SacVar iv; SacVar arg]))],

SacVar sel_var)] in

let wl = SacWith (wl_parts, wl_kind) in

(stmts @ [SacAssign (res_var, wl)], res_var)

| { expr_kind = EFilter (e_fun, e_arg) } ->

let stmts, fname = compile_stmts stmts e_fun in

let stmts, arg = compile_stmts stmts e_arg in

(* get the shape of the argument *)

let shape_var = fresh_var_name () in

let shape_funcall = SacFuncall ("_shape_A_", [SacVar arg]) in

let stmts = stmts @ [SacAssign (shape_var, shape_funcall)] in

(* construct the call to a macro. *)

let filter_call = SacFuncall ("FILTER", [SacVar fname; SacVar arg; SacVar shape_var]) in

let res_var = fresh_var_name () in

(stmts @ [SacAssign (res_var, filter_call)], res_var)

let compile_main (e: Ast.expr) =

let stmts, var = compile_stmts [] e in

(* Think how do we present final result. *)

let comment = Printf.sprintf "%s" (Print.expr_to_str e) in

let stmts = stmts @ [SacReturn (SacVar var)] in

mk_sac_function "main" [] stmts ~comment:comment

let compile_sac_function name varlst expr =

let rec vars_to_str vars =

match vars with

| [] -> ""

| h :: t -> Printf.sprintf "%s %s" h @@ vars_to_str t

let comment = Printf.sprintf "Λ%s . %s"

(vars_to_str varlst)

(Print.expr_to_str expr) in

let params = List.map (fun x -> (SacInt, x)) varlst in

let stmts, var = compile_stmts [] expr in

let stmts = stmts @ [SacReturn (SacVar var)] in

mk_sac_function name params stmts ~comment:comment

let sac_funs =

"// internal functions\n"

^ "bool\n"

^ "is_limit_ordinal (int[*] x)\n"

^ "{\n"

^ " return false;\n"

^ "}\n"

^ "\n"

^ "inline int[.]\n"

^ "zero_vec (int[.] x)\n"

^ "{\n"

^ " return with {}: genarray (_shape_A_ (x), 0);\n"

^ "}\n"

^ "\n"

^ "int[*]\n"

^ "zeroes (int[.] s)\n"

^ "{\n"

^ " return with{}: genarray (s, 0);\n"

^ "}\n"

^ "\n"

^ "inline int[.]\n"

^ "vec_concat (int[.] x, int[.] y)\n"

^ "{\n"

^ " l1 = _sel_VxA_ ([0], _shape_A_ (x));\n"

^ " l2 = _sel_VxA_ ([0], _shape_A_ (y));\n"

^ "\n"

^ " return with {\n"

^ " ([0] <= iv < [l1]): _sel_VxA_ (iv, x);\n"

^ " ([l1] <= iv < [_add_SxS_ (l1, l2)]): _sel_VxA_ ([_sub_SxS_ (_sel_VxA_ ([0], iv), l1)], y);\n"

^ " }: genarray ([_add_SxS_ (l1, l2)], 0);\n"

^ "}\n"

^ "\n"

^ "#define FILTER(__f, __arg, __sh_arg) \\\n"

^ " with { \\\n"

^ " (zero_vec (__sh_arg) <= __iv < __sh_arg) { \\\n"

^ " __el = _sel_VxA_ (__iv, __arg); \\\n"

^ " }: (__f (__el) ? [__el] : []); \\\n"

^ " }: fold (vec_concat, [])\n"

^ "\n"

let compile e m =

let p = Lifting.StringMap.fold

(fun var varlist_expr p ->

let varlst, expr = varlist_expr in

let sac_fun = compile_sac_function var varlst expr in

sac_fun :: p)

[] in

let p = p @ [compile_main e] in

let out = open_out !Globals.sac_out_file in

fprintf out "%s" sac_funs;

fprintf out "// --- sac-code ---\n";

print_sac_prog out p;

close_out out

FilesExpand file tree

compile_sac.ml

Latest commit

History

compile_sac.ml

File metadata and controls