implementation module Snug.Compile

import StdEnv

import Control.Monad
import Data.Func
import Data.List
import qualified Data.Map
from Data.Map import :: Map

import MIPS.MIPS32
import Snug.Compile.ABI
import Snug.Compile.Simulate
import Snug.Syntax

:: Locals :== Map SymbolIdent MemoryLocation

:: MemoryLocation
	= InRegister !Register
	| Indirect !Register !Offset

instance == (Namespaced id) | == id
where
	(==) x y = x.id == y.id && x.ns == y.ns

instance < (Namespaced id) | < id
where
	(<) x y
		| x.id < y.id = True
		| x.id > y.id = False
		| otherwise = x.ns < y.ns

compile :: !Namespace ![Definition] -> [Line]
compile ns defs =
	concatMap (compileDefinition ns globals) defs
where
	globals = combineGlobals
		[ builtin
		, gatherGlobals ns defs
		]

	builtin =
		{ constructors = 'Data.Map'.fromList
			[ ({ns="", id="INT"}, ConstructorDef "INT" [])
			]
		, functions = 'Data.Map'.newMap
		}

combineGlobals :: ![Globals] -> Globals
combineGlobals sets =
	{ constructors = 'Data.Map'.unions [g.constructors \\ g <- sets]
	, functions = 'Data.Map'.unions [g.functions \\ g <- sets]
	}

gatherGlobals :: !Namespace ![Definition] -> Globals
gatherGlobals ns defs =
	{ constructors = 'Data.Map'.fromList
		[ ({ns=ns, id=id}, cons)
		\\ DataDef _ _ conses <- defs
		, cons=:(ConstructorDef id _) <- conses
		]
	, functions = 'Data.Map'.fromList
		[ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))})
		\\ FunDef id args ret _ <- defs
		]
	}

lookupConstructor :: !Namespace !ConstructorIdent !Globals -> ?ConstructorDef
lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors

lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions

compileDefinition :: !Namespace !Globals !Definition -> [Line]
compileDefinition _ _ (TypeDef _ _) =
	[]
compileDefinition ns globals (DataDef _ _ constructors) =
	[ StartSection "data"
	: concatMap (compileConstructor ns globals) constructors
	]
compileDefinition ns globals (FunDef id args ret expr) =
	[ StartSection "text"
	, Global label
	// TODO: Ideally we would use the following here:
	//, Align 1
	//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
	//, RawByte (length args) // arity
	// But since SPIM does not allow .byte in the text section, we use:
	, Align 2
	, RawWord
		(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
		(length args << 8)) // arity
	// instead... (end modification)
	, Label label
	: map Instr (compileExpr ns globals locals expr)
	]
where
	label = functionLabel ns NodeEntry id
	locals = 'Data.Map'.fromList
		[ (id, Indirect FrontEvalPtr (offset*4))
		\\ (id,_) <- args
		& offset <- [1..]
		]

compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
compileConstructor ns _ (ConstructorDef id args) =
	[ Global label
	, Align 1
	, Label label
	, RawByte (length args) // pointer arity
	, RawByte 0 // basic value arity
	, RawByte 0 // number of arguments still to be curried in
	]
where
	label = constructorLabel ns id

compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
compileExpr ns globals locals expr = simulate $
	simulator ns globals locals expr >>|
	indirectAndEval

simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
simulator _ _ _ (BasicValue bv) =
	pushBasicValue bv >>|
	buildCons (constructorLabel "" (label bv)) 1
where
	label (BVInt _) = "INT"
	label (BVChar _) = "CHAR"
simulator ns globals locals (Symbol id) = // TODO include locals
	case lookupFunction ns id globals of
		?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
		?Just info ->
			case info.arity of
				0 ->
					buildThunk (functionLabel ns NodeEntry id) 0
				_ ->
					abort "symbol with arity > 0\n" // TODO implement
simulator ns globals locals expr=:(ExpApp _ _) =
	case f of
		Symbol id -> // TODO include locals
			case lookupFunction ns id globals of
				?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
				?Just info | info.arity == length args ->
					mapM_ (simulator ns globals locals) args >>|
					buildThunk (functionLabel ns NodeEntry id) info.arity
				_ -> abort ("arity mismatch in application\n") // TODO implement
		Constructor id ->
			case lookupConstructor ns id globals of
				?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up
				?Just (ConstructorDef _ arg_types) | length arg_types == length args ->
					mapM_ (simulator ns globals locals) args >>|
					buildCons (constructorLabel ns id) (length args)
				_ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement
		_ -> // TODO
			abort "unexpected lhs of function application\n"
where
	(f, args) = linearizeApp expr []

	linearizeApp (ExpApp f x) xs = linearizeApp f [x:xs]
	linearizeApp e xs = (e, xs)
simulator _ _ _ _ = // TODO
	pushBasicValue (BVInt 0) >>|
	buildCons (constructorLabel "" "INT") 1
//	| Symbol !SymbolIdent
//	| Constructor !ConstructorIdent
//	| Case !Expression ![CaseAlternative]
//	| ExpApp !Expression !Expression