implementation module Snug.Compile

import StdEnv

import Data.List
import qualified Data.Map
from Data.Map import :: Map
import Text

import MIPS.MIPS32
import Snug.Syntax

:: Locals :== Map SymbolIdent MemoryLocation

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

:: EntryPoint
	= NodeEntry

BackPrintPtr :== S 0
FrontPrintPtr :== S 1
BackEvalPtr :== S 2
FrontEvalPtr :== S 3
HeapPtr :== GP

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 _ _ _ (BasicValue bv) =
	// Build new node
	[ LoadAddress (T 0) (Address 2 (constructorLabel "" (label bv)))
	, StoreWord (T 0) 0 HeapPtr
	] ++
	loadImmediate bv ++
	[ StoreWord (T 0) 4 HeapPtr
	// Overwrite old node with indirection
	, LoadAddress (T 0) (Address 0 (functionLabel "" NodeEntry "indir"))
	, StoreWord (T 0) 0 FrontEvalPtr
	, StoreWord HeapPtr 4 FrontEvalPtr
	// Update front and heap pointers; return
	, Move FrontEvalPtr HeapPtr
	, Jump NoLink (Direct (Address 0 "eval"))
	, AddImmediate Signed GP GP (Immediate 8)
	]
where
	label (BVInt _) = "INT"
	label (BVChar _) = "CHAR"

	loadImmediate (BVInt i)
		| 0 <= i && i < 0x10000 =
			[ OrImmediate (T 0) R0 (Immediate i)
			]
		| 0 > i && i >= -0x8000 =
			[ AddImmediate Signed (T 0) R0 (Immediate i)
			]
		| otherwise =
			[ LoadUpperImmediate (T 0) (Immediate (i >> 16))
			, OrImmediate (T 0) (T 0) (Immediate (i bitand 0xffff))
			]
compileExpr _ _ _ _ = [Nop]// TODO
//	| Symbol !SymbolIdent
//	| Constructor !ConstructorIdent
//	| Case !Expression ![CaseAlternative]
//	| ExpApp !Expression !Expression

constructorLabel :: !Namespace !ConstructorIdent -> Label
constructorLabel "" id = "_c" +++ id // for built-in constructors
constructorLabel ns id = concat4 "__" ns "_c" id // TODO escaping

functionLabel :: !Namespace !EntryPoint !ConstructorIdent -> Label
functionLabel ns entry_point id // TODO escaping
	| size ns == 0
		= {#'_',e} +++ id
		= concat4 "__" ns {#'_',e} id
where
	e = case entry_point of
		NodeEntry -> 'n'