/* Tuplr: A programming language
 * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
 *
 * Tuplr is free software: you can redistribute it and/or modify it under
 * the terms of the GNU Affero General Public License as published by the
 * Free Software Foundation, either version 3 of the License, or (at your
 * option) any later version.
 *
 * Tuplr is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
 * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
 * Public License for more details.
 *
 * You should have received a copy of the GNU Affero General Public License
 * along with Tuplr.  If not, see <http://www.gnu.org/licenses/>.
 */

#include <map>
#include <sstream>
#include <boost/format.hpp>
#include "llvm/Analysis/Verifier.h"
#include "llvm/Assembly/AsmAnnotationWriter.h"
#include "llvm/DerivedTypes.h"
#include "llvm/ExecutionEngine/ExecutionEngine.h"
#include "llvm/Instructions.h"
#include "llvm/Module.h"
#include "llvm/ModuleProvider.h"
#include "llvm/PassManager.h"
#include "llvm/Support/IRBuilder.h"
#include "llvm/Target/TargetData.h"
#include "llvm/Transforms/Scalar.h"
#include "tuplr.hpp"

using namespace llvm;
using namespace std;
using boost::format;

inline Value*    LLVal(CValue     v) { return static_cast<Value*>(v); }
inline Function* LLFunc(CFunction f) { return static_cast<Function*>(f); }

struct CEngine {
	CEngine();
	Module*          module;
	ExecutionEngine* engine;
	IRBuilder<>      builder;
};

const Type*
lltype(AType* t)
{
	switch (t->kind) {
	case AType::VAR:
		return NULL;
	case AType::PRIM:
		if (t->at(0)->str() == "Bool")  return Type::Int1Ty;
		if (t->at(0)->str() == "Int")   return Type::Int32Ty;
		if (t->at(0)->str() == "Float") return Type::FloatTy;
		throw Error(string("Unknown primitive type `") + t->str() + "'");
	case AType::EXPR:
		if (t->at(0)->str() == "Pair") {
			vector<const Type*> types;
			for (size_t i = 1; i < t->size(); ++i)
				types.push_back(lltype(dynamic_cast<AType*>(t->at(i))));
			return PointerType::get(StructType::get(types, false), 0);
		}
	}
	return NULL; // not reached
}

CEngine::CEngine()
	: module(new Module("tuplr"))
	, engine(ExecutionEngine::create(module))
{
}

struct CEnvPimpl {
	CEnvPimpl(CEngine& engine)
		: module(engine.module), emp(module), opt(&emp)
	{
		// Set up the optimizer pipeline:
		const TargetData* target = engine.engine->getTargetData();
		opt.add(new TargetData(*target));          // Register target arch
		opt.add(createInstructionCombiningPass()); // Simple optimizations
		opt.add(createReassociatePass());          // Reassociate expressions
		opt.add(createGVNPass());                  // Eliminate Common Subexpressions
		opt.add(createCFGSimplificationPass());    // Simplify control flow
	}

	Module*                module;
	ExistingModuleProvider emp;
	FunctionPassManager    opt;
	Function*              alloc;
};

CEnv::CEnv(PEnv& p, TEnv& t, CEngine& e, ostream& os, ostream& es)
	: engine(e), penv(p), tenv(t), symID(0), alloc(0), log(os, es), _pimpl(new CEnvPimpl(e))
{
}

CEnv::~CEnv()
{
	delete _pimpl;
}

CValue
CEnv::compile(AST* obj)
{
	CValue* v = vals.ref(obj);
	return (v) ? *v : vals.def(obj, obj->compile(*this));
}

void
CEnv::optimise(CFunction f)
{
	verifyFunction(*static_cast<Function*>(f));
	_pimpl->opt.run(*static_cast<Function*>(f));
}

void
CEnv::write(std::ostream& os)
{
	AssemblyAnnotationWriter writer;
	engine.module->print(os, &writer);
}

#define LITERAL(CT, NAME, COMPILED) \
template<> CValue \
ASTLiteral<CT>::compile(CEnv& cenv) { return (COMPILED); } \
template<> void \
ASTLiteral<CT>::constrain(TEnv& tenv) const { tenv.constrain(this, tenv.named(NAME)); }

/// Literal template instantiations
LITERAL(int32_t, "Int",   ConstantInt::get(Type::Int32Ty, val, true))
LITERAL(float,   "Float", ConstantFP::get(Type::FloatTy, val))
LITERAL(bool,    "Bool",  ConstantInt::get(Type::Int1Ty, val, false))

static Function*
compileFunction(CEnv& cenv, const std::string& name, const Type* retT, const ASTTuple& prot,
		const vector<string> argNames=vector<string>())
{
	Function::LinkageTypes linkage = Function::ExternalLinkage;

	vector<const Type*> cprot;
	for (size_t i = 0; i < prot.size(); ++i) {
		AType* at = cenv.tenv.type(prot.at(i));
		if (!lltype(at)) throw Error("function parameter is untyped");
		cprot.push_back(lltype(at));
	}

	if (!retT) throw Error("function return is untyped");
	FunctionType* fT = FunctionType::get(static_cast<const Type*>(retT), cprot, false);
	Function*     f  = Function::Create(fT, linkage, name, cenv.engine.module);

	if (f->getName() != name) {
		f->eraseFromParent();
		throw Error("function redefined");
	}

	// Set argument names in generated code
	Function::arg_iterator a = f->arg_begin();
	if (!argNames.empty())
		for (size_t i = 0; i != prot.size(); ++a, ++i)
			a->setName(argNames.at(i));
	else
		for (size_t i = 0; i != prot.size(); ++a, ++i)
			a->setName(prot.at(i)->str());
	
	BasicBlock* bb = BasicBlock::Create("entry", f);
	cenv.engine.builder.SetInsertPoint(bb);

	return f;
}


/***************************************************************************
 * Code Generation                                                         *
 ***************************************************************************/

void
ASTSymbol::lift(CEnv& cenv)
{
	if (!cenv.code.ref(this))
		throw Error((string("undefined symbol `") + cppstr + "'").c_str(), loc);
}

CValue
ASTSymbol::compile(CEnv& cenv)
{
	return cenv.compile(*cenv.code.ref(this));
}

void
ASTClosure::lift(CEnv& cenv)
{
	AType* type = cenv.tenv.type(this);
	if (!type->concrete() || funcs.find(type))
		return;
	
	cenv.push();

	// Write function declaration
	string name = this->name == "" ? cenv.gensym("_fn") : this->name;
	Function* f = compileFunction(cenv, name, lltype(cenv.tenv.type(at(2))), *prot());

	// Bind argument values in CEnv
	vector<Value*> args;
	const_iterator p = prot()->begin();
	for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p)
		cenv.vals.def(dynamic_cast<ASTSymbol*>(*p), &*a);

	// Write function body
	try {
		cenv.precompile(this, f); // Define our value first for recursion
		CValue retVal = cenv.compile(at(2));
		cenv.engine.builder.CreateRet(LLVal(retVal)); // Finish function
		cenv.optimise(LLFunc(f));
		funcs.push_back(make_pair(type, f));
	} catch (Error& e) {
		f->eraseFromParent(); // Error reading body, remove function
		throw e;
	}

	cenv.pop();
}

template<typename T>
T
checked_cast(AST* ast)
{
	T t = dynamic_cast<T>(ast);
	if (!t)
		throw Error((format("internal error: `%1%' should be a `%2%'")
				% typeid(ast).name() % typeid(T).name()).str(), ast->loc);
	return t;
}

static
AST*
maybeLookup(CEnv& cenv, AST* ast)
{
	ASTSymbol* s = dynamic_cast<ASTSymbol*>(ast);
	if (s) {
		AST** val = cenv.code.ref(s);
		if (val) return *val;
	}
	return ast;
}

CValue
ASTClosure::compile(CEnv& cenv)
{
	return funcs.find(cenv.tenv.type(this));
}

void
ASTCall::lift(CEnv& cenv)
{
	ASTClosure* c = dynamic_cast<ASTClosure*>(maybeLookup(cenv, at(0)));
	
	// Lift arguments
	for (size_t i = 1; i < size(); ++i)
		at(i)->lift(cenv);
	
	if (!c) return; // Primitive

	// Extend environment with bound and typed parameters
	cenv.push();
	if (c->prot()->size() < size() - 1)
		throw Error((format("too many arguments to function `%1%'") % at(0)->str()).str(), loc);
	if (c->prot()->size() > size() - 1)
		throw Error((format("too few arguments to function `%1%'") % at(0)->str()).str(), loc);

	for (size_t i = 1; i < size(); ++i)
		cenv.code.def(checked_cast<ASTSymbol*>(c->prot()->at(i-1)), at(i));

	c->lift(cenv); // Lift called closure
	cenv.pop(); // Restore environment
}

CValue
ASTCall::compile(CEnv& cenv)
{
	AST*      c = maybeLookup(cenv, at(0));
	Function* f = dynamic_cast<Function*>(LLVal(cenv.compile(c)));
	if (!f) throw Error("callee failed to compile", loc);

	vector<Value*> params(size() - 1);
	for (size_t i = 1; i < size(); ++i)
		params[i-1] = LLVal(cenv.compile(at(i)));

	return cenv.engine.builder.CreateCall(f, params.begin(), params.end(), "calltmp");
}

void
ASTDefinition::lift(CEnv& cenv)
{
	if (cenv.code.ref(checked_cast<ASTSymbol*>(at(1))))
		throw Error(string("`") + at(1)->str() + "' redefined", loc);
	cenv.code.def((ASTSymbol*)at(1), at(2)); // Define first for recursion
	at(2)->lift(cenv);
}

CValue
ASTDefinition::compile(CEnv& cenv)
{
	return cenv.compile(at(2));
}

CValue
ASTIf::compile(CEnv& cenv)
{
	typedef vector< pair<Value*, BasicBlock*> > Branches;
	Function*     parent  = cenv.engine.builder.GetInsertBlock()->getParent();
	BasicBlock*   mergeBB = BasicBlock::Create("endif");
	BasicBlock*   nextBB  = NULL;
	Branches      branches;
	for (size_t i = 1; i < size() - 1; i += 2) {
		Value*      condV  = LLVal(cenv.compile(at(i)));
		BasicBlock* thenBB = BasicBlock::Create((format("then%1%") % ((i+1)/2)).str());

		nextBB = BasicBlock::Create((format("else%1%") % ((i+1)/2)).str());

		cenv.engine.builder.CreateCondBr(condV, thenBB, nextBB);

		// Emit then block for this condition
		parent->getBasicBlockList().push_back(thenBB);
		cenv.engine.builder.SetInsertPoint(thenBB);
		Value* thenV = LLVal(cenv.compile(at(i+1)));
		cenv.engine.builder.CreateBr(mergeBB);
		branches.push_back(make_pair(thenV, cenv.engine.builder.GetInsertBlock()));

		parent->getBasicBlockList().push_back(nextBB);
		cenv.engine.builder.SetInsertPoint(nextBB);
	}

	// Emit final else block
	cenv.engine.builder.SetInsertPoint(nextBB);
	Value* elseV = LLVal(cenv.compile(at(size() - 1)));
	cenv.engine.builder.CreateBr(mergeBB);
	branches.push_back(make_pair(elseV, cenv.engine.builder.GetInsertBlock()));

	// Emit merge block (Phi node)
	parent->getBasicBlockList().push_back(mergeBB);
	cenv.engine.builder.SetInsertPoint(mergeBB);
	PHINode* pn = cenv.engine.builder.CreatePHI(lltype(cenv.tenv.type(this)), "ifval");

	FOREACH(Branches::iterator, i, branches)
		pn->addIncoming(i->first, i->second);

	return pn;
}

CValue
ASTPrimitive::compile(CEnv& cenv)
{
	Value*       a     = LLVal(cenv.compile(at(1)));
	Value*       b     = LLVal(cenv.compile(at(2)));
	bool         isInt = cenv.tenv.type(at(1))->str() == "Int";
	const string n     = dynamic_cast<ASTSymbol*>(at(0))->str();

	// Binary arithmetic operations
	Instruction::BinaryOps op = (Instruction::BinaryOps)0;
	if (n == "+")   op = Instruction::Add;
	if (n == "-")   op = Instruction::Sub;
	if (n == "*")   op = Instruction::Mul;
	if (n == "and") op = Instruction::And;
	if (n == "or")  op = Instruction::Or;
	if (n == "xor") op = Instruction::Xor;
	if (n == "/")   op = isInt ? Instruction::SDiv : Instruction::FDiv;
	if (n == "%")   op = isInt ? Instruction::SRem : Instruction::FRem;
	if (op != 0) {
		Value* val = cenv.engine.builder.CreateBinOp(op, a, b);
		for (size_t i = 3; i < size(); ++i)
			val = cenv.engine.builder.CreateBinOp(op, val, LLVal(cenv.compile(at(i))));
		return val;
	}

	// Comparison operations
	CmpInst::Predicate pred = (CmpInst::Predicate)0;
	if (n == "=")  pred = isInt ? CmpInst::ICMP_EQ  : CmpInst::FCMP_OEQ;
	if (n == "!=") pred = isInt ? CmpInst::ICMP_NE  : CmpInst::FCMP_ONE;
	if (n == ">")  pred = isInt ? CmpInst::ICMP_SGT : CmpInst::FCMP_OGT;
	if (n == ">=") pred = isInt ? CmpInst::ICMP_SGE : CmpInst::FCMP_OGE;
	if (n == "<")  pred = isInt ? CmpInst::ICMP_SLT : CmpInst::FCMP_OLT;
	if (n == "<=") pred = isInt ? CmpInst::ICMP_SLE : CmpInst::FCMP_OLE;
	if (pred != 0) {
		if (isInt)
			return cenv.engine.builder.CreateICmp(pred, a, b);
		else
			return cenv.engine.builder.CreateFCmp(pred, a, b);
	}
	
	throw Error("unknown primitive", loc);
}

AType*
ASTConsCall::functionType(CEnv& cenv)
{
	ASTTuple* protTypes = new ASTTuple(loc, cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), 0);
	AType* cellType = new AType(loc,
			cenv.penv.sym("Pair"), cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), 0);
	return new AType(at(0)->loc, cenv.penv.sym("Fn"), protTypes, cellType, 0);
}

void
ASTConsCall::lift(CEnv& cenv)
{
	AType* funcType = functionType(cenv);
	if (funcs.find(functionType(cenv)))
		return;
	
	ASTCall::lift(cenv);
	
	ASTTuple* prot = new ASTTuple(loc, at(1), at(2), 0);

	vector<const Type*> types;
	size_t sz = 0;
	for (size_t i = 1; i < size(); ++i) {
		const Type* t = lltype(cenv.tenv.type(at(i)));
		types.push_back(t);
		sz += t->getPrimitiveSizeInBits();
	}
	sz = (sz % 8 == 0) ? sz / 8 : sz / 8 + 1;
	
	llvm::IRBuilder<>& builder = cenv.engine.builder;

	StructType* sT = StructType::get(types, false);
	Type*       pT = PointerType::get(sT, 0);
	
	// Write function declaration
	vector<string> argNames;
	argNames.push_back("car");
	argNames.push_back("cdr");
	Function* func = compileFunction(cenv, cenv.gensym("cons"), pT, *prot, argNames);

	Value* mem  = builder.CreateCall(LLVal(cenv.alloc), ConstantInt::get(Type::Int32Ty, sz), "mem");
	Value* cell = builder.CreateBitCast(mem, pT, "cell");
	Value* s    = builder.CreateGEP(cell, ConstantInt::get(Type::Int32Ty, 0), "pair");
	Value* carP = builder.CreateStructGEP(s, 0, "car");
	Value* cdrP = builder.CreateStructGEP(s, 1, "cdr");
	
	Function::arg_iterator ai = func->arg_begin();
	Value& carArg = *ai++;
	Value& cdrArg = *ai++;
	builder.CreateStore(&carArg, carP);
	builder.CreateStore(&cdrArg, cdrP);
	builder.CreateRet(cell);
	
	cenv.optimise(func);
	funcs.push_back(make_pair(funcType, func));
}

CValue
ASTConsCall::compile(CEnv& cenv)
{
	vector<Value*> params(size() - 1);
	for (size_t i = 1; i < size(); ++i)
		params[i-1] = LLVal(cenv.compile(at(i)));

	return cenv.engine.builder.CreateCall(LLFunc(funcs.find(functionType(cenv))),
			params.begin(), params.end());
}

CValue
ASTCarCall::compile(CEnv& cenv)
{
	AST*   arg  = maybeLookup(cenv, at(1));
	Value* sP   = LLVal(cenv.compile(arg));
	Value* s    = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
	Value* carP = cenv.engine.builder.CreateStructGEP(s, 0, "car");
	return cenv.engine.builder.CreateLoad(carP);
}

CValue
ASTCdrCall::compile(CEnv& cenv)
{
	AST*   arg  = maybeLookup(cenv, at(1));
	Value* sP   = LLVal(cenv.compile(arg));
	Value* s    = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair");
	Value* cdrP = cenv.engine.builder.CreateStructGEP(s, 1, "cdr");
	return cenv.engine.builder.CreateLoad(cdrP);
}


/***************************************************************************
 * EVAL/REPL                                                               *
 ***************************************************************************/

const string
call(AType* retT, void* fp)
{
	std::stringstream ss;
	if (lltype(retT) == Type::Int32Ty)
		ss << ((int32_t (*)())fp)();
	else if (lltype(retT) == Type::FloatTy)
		ss << showpoint << ((float (*)())fp)();
	else if (lltype(retT) == Type::Int1Ty)
		ss << (((bool (*)())fp)() ? "#t" : "#f");
	else
		ss << ((void* (*)())fp)();
	return ss.str();
}

int
eval(CEnv& cenv, const string& name, istream& is)
{
	AST*   result     = NULL;
	AType* resultType = NULL;
	list< pair<SExp, AST*> > exprs;
	Cursor cursor(name);
	try {
		while (true) {
			SExp exp = readExpression(cursor, is);
			if (exp.type == SExp::LIST && exp.list.empty())
				break;

			result = parseExpression(cenv.penv, exp); // Parse input
			result->constrain(cenv.tenv); // Constrain types
			cenv.tenv.solve(); // Solve and apply type constraints
			resultType = cenv.tenv.type(result);
			result->lift(cenv); // Lift functions
			exprs.push_back(make_pair(exp, result));
		}

		if (!resultType || resultType->var()) throw Error("body is undefined/untyped", cursor);
		
		const Type* ctype = lltype(resultType);
		if (!ctype) throw Error("body has non-compilable type", cursor);

		// Create function for top-level of program
		Function* f = compileFunction(cenv, "main", ctype, ASTTuple());

		// Compile all expressions into it
		Value* val = NULL;
		for (list< pair<SExp, AST*> >::const_iterator i = exprs.begin(); i != exprs.end(); ++i)
			val = LLVal(cenv.compile(i->second));

		// Finish function
		cenv.engine.builder.CreateRet(val);
		cenv.optimise(f);

		cenv.log.out << call(resultType, cenv.engine.engine->getPointerToFunction(f))
		    << " : " << resultType << endl;
	} catch (Error& e) {
		cenv.log.err << e.what() << endl;
		return 1;
	}
	return 0;
}

int
repl(CEnv& cenv)
{
	while (1) {
		cenv.log.out << "() ";
		cenv.log.out.flush();
		Cursor cursor("(stdin)");
		try {
			SExp exp = readExpression(cursor, std::cin);
			if (exp.type == SExp::LIST && exp.list.empty())
				break;

			AST* body = parseExpression(cenv.penv, exp); // Parse input
			body->constrain(cenv.tenv); // Constrain types
			cenv.tenv.solve(); // Solve and apply type constraints

			AType* bodyT = cenv.tenv.type(body);
			if (!bodyT) throw Error("call to untyped body", cursor);

			body->lift(cenv);

			if (lltype(bodyT)) {
				// Create anonymous function to insert code into
				Function* f = compileFunction(cenv, cenv.gensym("_repl"), lltype(bodyT), ASTTuple());
				try {
					Value* retVal = LLVal(cenv.compile(body));
					cenv.engine.builder.CreateRet(retVal); // Finish function
					cenv.optimise(f);
				} catch (Error& e) {
					f->eraseFromParent(); // Error reading body, remove function
					throw e;
				}
				cenv.log.out << call(bodyT, cenv.engine.engine->getPointerToFunction(f));
			} else {
				cenv.log.out << ";   " << cenv.compile(body);
			}
			cenv.log.out << " : " << cenv.tenv.type(body) << endl;
		} catch (Error& e) {
			cenv.log.err << e.what() << endl;
		}
	}
	return 0;
}

CEnv*
newCenv(PEnv& penv, TEnv& tenv)
{
	CEngine* engine = new CEngine();
	CEnv*    cenv   = new CEnv(penv, tenv, *engine);
	
	// Host provided allocation primitive prototypes
	std::vector<const Type*> argsT(1, Type::Int32Ty);
	FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false);
	cenv->alloc = Function::Create(funcT, Function::ExternalLinkage, "malloc", engine->module);

	return cenv;
}