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 =
		{ constructors = 'Data.Map'.fromList
			[ ({ns="", id="INT"}, ConstructorDef "INT" [])
			]
		, functions = 'Data.Map'.newMap
		}

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"
	, Align 3 // to have 3 bits unused in addresses
	, RawWord (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
	, RawWord (length args) // arity
	, Label (functionLabel ns NodeEntry id)
	: map Instr (compileExpr ns globals locals expr)
	]
where
	locals = 'Data.Map'.fromList
		[ (id, Indirect FrontEvalPtr (offset*4))
		\\ (id,_) <- args
		& offset <- [1..]
		]

compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
compileConstructor ns _ (ConstructorDef id args) =
	[ Align 3 // to have 3 bits unused in addresses
	, Label (constructorLabel ns id)
	, RawWord (length args) // arity
	, RawWord (size id) // length name
	, RawAscii id // name
	]

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 _ _ _ _ = // TODO
	pushBasicValue (BVInt 0) >>|
	buildCons (constructorLabel "" "INT") 1
//	| Symbol !SymbolIdent
//	| Constructor !ConstructorIdent
//	| Case !Expression ![CaseAlternative]
//	| ExpApp !Expression !Expression