\ignore{
\begin{code}
module GCode (
    module GCode,
    module PrimOp,
    module StgSyn,
    module Unique    
    ) where

import Data.Int (Int32,Int64)

import Brianweb.Data.SoftFloat (Float32,Float64)

import TyCon
import TysPrim
import Outputable
import ForeignCall (ForeignCall,ForeignExport)
import PrimOp (PrimOp(..))
import StgSyn (UpdateFlag(..),isUpdatable,isReEntrant)
import Unique (Unique,mkPseudoUniqueC,mkBuiltinUnique)
import UniqFM
import PrelNames
import FastString
import Maybes
import OrdList
import UniqSet

#include "HsVersions.h"
\end{code}
}

\begin{code}
type Stmnts = GenStmnts Unique
type LStmnts = GenStmnts Int
type Stmnt = GenStmnt Unique
type LStmnt = GenStmnt Int
type Call = GenCall Unique
type LCall = GenCall Int
type Loc = GenLoc Unique
type LLoc = GenLoc Int
type Closure = GenClosure Unique
type LClosure = GenClosure Int
type Module = GenModule Unique
type LModule = GenModule Int
\end{code}

\begin{code}
type Name = FastString
type QName = (Name,Name)
type Tag = Int32
type Signature = ([Type],[Type])
type GenStmnts a = OrdList (GenStmnt a)
\end{code}

\begin{code}
data GenModule a = Module
    { m_name :: Name
    , m_closures :: [GenClosure a]
    , m_globals :: [GlobalDecl]
    , m_init :: GenStmnts a
    , m_exports :: [Export] }

instance Outputable a => Outputable (GenModule a) where
    ppr = pprModule

data GlobalDecl = GlobalDecl
    { gd_name :: Name
    , gd_type :: Type
    , gd_exported :: Bool }

data Export = Export 
    { e_name :: Name
    , e_fexport :: ForeignExport
    , e_signature :: Signature }
\end{code}

\begin{code}
data GenClosure a = Closure
    { c_name :: Name
    , c_payload :: [Type]
    , c_tag :: Int32
    , c_update :: UpdateFlag
    , c_code :: GenStmnts a }

instance Outputable a => Outputable (GenClosure a) where
    ppr = pprClosure

data GenStmnt a
    = Move (GenLoc a) (GenLoc a)
    | Alloc QName (GenLoc a)
    | Switch (GenLoc a) [(Tag,GenStmnts a)] (GenStmnts a) -- Default (must exist)
    | PrimOp PrimOp [Type] [GenLoc a] [GenLoc a]
    | Foreign ForeignCall Signature [GenLoc a] [GenLoc a]
    | Call (GenCall a)
    | TailCall (GenCall a)
    | Return
    | Update (GenLoc a)
    | Trim (UniqFM a)

instance Outputable a => Outputable (GenStmnt a) where
    ppr = pprStmnt

data GenCall a = RtsCall Name | FunCall (GenLoc a)

instance Outputable a => Outputable (GenCall a) where
    ppr (RtsCall n) = ftext n
    ppr (FunCall l) = ppr l
\end{code}

\begin{code}
assign :: SDoc
assign = ptext SLIT(":=")

block :: SDoc -> SDoc
block doc = lbrace $+$ nest 4 doc $+$ rbrace

pprModule :: Outputable a => GenModule a -> SDoc
pprModule (Module name cs _ ss _) 
    =  ptext SLIT("module") <+> ftext name <+> ptext SLIT("where")
    $$ vcat (map ppr cs)
    $$ pprStmnts ss

pprQName :: QName -> SDoc
pprQName (m,n) 
    | nullFS m = ftext n
    | otherwise = ftext m <> dot <> ftext n

pprStmnt :: Outputable a => GenStmnt a -> SDoc
pprStmnt (Move src dst) = ppr dst <+> assign <+> ppr src
pprStmnt (Alloc qn l) = ppr l <+> assign <+> text "new" <+> pprQName qn
pprStmnt (Switch l arms def) 
    = ptext SLIT("switch") <> parens (ppr l) $+$
      block (vcat [pprArm (integer (toInteger i)) ss | (i,ss) <- arms] $+$ pprArm (ptext SLIT("default")) def)
pprStmnt (PrimOp op ty_args args rets)
    = brackets (pprWithCommas ppr rets) <+> assign <+> ppr op <> angleBrackets (pprWithCommas ppr ty_args) <+> parens (pprWithCommas ppr args)
pprStmnt (Foreign fun _ args rets)
    = brackets (pprWithCommas ppr rets) <+> assign <+> ppr fun <+> parens (pprWithCommas ppr args)
pprStmnt (Call x) = ptext SLIT("CALL") <> parens (ppr x)
pprStmnt (TailCall x) = ptext SLIT("TAILCALL") <> parens (ppr x)
pprStmnt Return = ptext SLIT("RETURN") <> parens empty
pprStmnt (Update x) = ptext SLIT("UPDATE") <> parens (ppr x)
pprStmnt (Trim s) = ptext SLIT("// Environment: ") <+> pprWithCommas ppr (uniqSetToList s)

pprArm :: Outputable a => SDoc -> GenStmnts a -> SDoc
pprArm label body = label <> colon $+$ nest 4 (pprStmnts body)

pprStmnts :: Outputable a => GenStmnts a -> SDoc
pprStmnts ss = vcat [ppr s | s <- fromOL ss]

pprClosure :: Outputable a => GenClosure a -> SDoc
pprClosure (Closure name fvs _ _ ss)
    = ftext name <> angleBrackets (pprWithCommas ppr fvs) $+$
      block (pprStmnts ss)
\end{code}

\begin{code}
data Type = PrimTy TyCon [Type] | LiftedTy | ClosureTy QName deriving Eq

instance Outputable Type where
    ppr (PrimTy tc []) 
        | tc == intPrimTyCon = ptext SLIT("int")
        | otherwise = ppr tc
    ppr (PrimTy tc xs) = parens (ppr tc <+> fsep (map ppr xs))
    ppr LiftedTy = ptext SLIT("clo")
    ppr (ClosureTy qn) = pprQName qn
\end{code}

\begin{code}
type RegClass = Char

data GenLoc a 
    = Var Type a
    | Field (GenLoc a) Type Int
    | Reg Type Int
    | Global Type QName
    | Literal Literal
\end{code}

\begin{code}
thisUnique :: Unique
thisUnique = mkPseudoUniqueC 0

locType :: GenLoc a -> Type
locType (Var t _) = t
locType (Field _ t _) = t
locType (Reg t _) = t
locType (Global t _) = t
locType (Literal l) = litType l

locDeps :: GenLoc a -> [GenLoc a]
locDeps (Field l _ _) = l : locDeps l
locDeps _ = []

-- This is sort of dangerous if you're not careful. It should mostly be used
-- for further specifying a type (LiftedTy -> ClosureTy, etc)
setLocType :: Outputable a => GenLoc a -> Type -> GenLoc a
setLocType (Var _ i) t = Var t i
setLocType (Field l _ i) t = Field l t i
setLocType (Reg _ i) t = Reg t i
setLocType (Global _ qn) t = Global t qn
setLocType loc _ = pprPanic "setLocType" (ppr loc)
\end{code}

\begin{code}
volatile :: GenLoc a -> Bool
volatile Reg{} = True
volatile l = any volatile (locDeps l)
\end{code}

\begin{code}
instance Outputable a => Outputable (GenLoc a) where
    ppr = pprLoc

pprLoc :: Outputable a => GenLoc a -> SDoc
pprLoc (Var t i) = char 't' <> underscore <> ppr i <> angleBrackets (ppr t)
pprLoc (Field l t i) = ppr l <> brackets (int i) <> angleBrackets (ppr t)
pprLoc (Literal l) = ppr l
pprLoc (Global t qn) = pprQName qn <> angleBrackets (ppr t)
pprLoc (Reg t i) = char 'r' <> underscore <> int i <> angleBrackets (ppr t)
\end{code}

\begin{code}
data Literal = LInt Int32 | LLong Int64 
             | LFloat Float32 | LDouble Float64
             | LString FastString 
             | LNull Type 

instance Eq Literal where
    LInt x == LInt y = x == y
    LLong x == LLong y = x == y
    LFloat x == LFloat y = x == y
    LDouble x == LDouble y = x == y
    LString x == LString y = x == y
    LNull _ == LNull _ = True
    _ == _ = False

instance Outputable Literal where
    ppr = pprLiteral
    
pprLiteral :: Literal -> SDoc
pprLiteral (LInt i) = integer (toInteger i)
pprLiteral (LLong l) = integer (toInteger l)
pprLiteral (LFloat f) = rational (toRational f)
pprLiteral (LDouble d) = rational (toRational d)
pprLiteral (LString s) = text (show s)
pprLiteral (LNull t) = ptext SLIT("null") <> angleBrackets (ppr t)

litType :: Literal -> Type
litType (LInt _) = PrimTy intPrimTyCon []
litType (LLong _) = PrimTy int64PrimTyCon []
litType (LString _) = PrimTy stringPrimTyCon []
litType (LFloat _) = PrimTy floatPrimTyCon []
litType (LDouble _) = PrimTy doublePrimTyCon []
litType (LNull t) = t
\end{code}