path: root/ghc/compiler/ilxGen/IlxGen.lhs

%
\section{Generate .NET extended IL}

\begin{code}
module IlxGen( ilxGen ) where

#include "HsVersions.h"

import Char	( ord, chr )
import StgSyn
import Id	( idType, idName, isDeadBinder, idArity )
import Var	( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
import VarEnv
import VarSet   ( isEmptyVarSet )
import TyCon	( TyCon,  tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, 
		  tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
		)
import Type	( liftedTypeKind, openTypeKind, unliftedTypeKind,
		  isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep,
		  splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
		)
import TypeRep	( Type(..) )
import DataCon	( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) )
import Literal	( Literal(..) )
import PrelNames	-- Lots of keys
import PrimOp		( PrimOp(..) )
import ForeignCall	( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) )
import TysWiredIn	( mkTupleTy, tupleCon )
import PrimRep		( PrimRep(..) )
import Name		( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) )
import Subst   		( substTyWith )

import Module		( Module, PackageName, ModuleName, moduleName, 
                          modulePackage, basePackage,
			  isHomeModule, isVanillaModule,
                          pprModuleName, mkHomeModule, mkModuleName
			)

import UniqFM
import BasicTypes	( Boxity(..) )
import CStrings		( CLabelString, pprCLabelString )
import Outputable
import Char		( ord )
import List		( partition, elem, insertBy,any  )
import UniqSet
import PprType		( pprType )	-- Only called in debug messages

import TysPrim  ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )

-- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different
-- versions of compiled Haskell code.  We add a ".O" to all assembly and module 
-- names when this is set (because that's clue that -O was set).  
-- One day this will be configured by the command line.
import CmdLineOpts	( opt_InPackage, opt_SimplDoEtaReduction )

import Util		( lengthIs, equalLength )

\end{code}



%************************************************************************
%*									*
\subsection{Main driver}
%*									*
%************************************************************************

\begin{code}
ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc
	-- The TyCons should include those arising from classes
ilxGen mod tycons binds_w_srts
  =  vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'",
	    text ".assembly extern 'mscorlib' {}",
	    vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
            vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)),
            vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)),
            vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))),
            vcat (map (ilxTyCon topenv) data_tycons),
            vcat (map (ilxBindClosures topenv) binds),
	    ilxTopBind mod topenv toppairs
	 ]
    where
      binds = map fst binds_w_srts
      toppairs = ilxPairs binds
      topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs
 	-- Generate info from class decls as well
      (import_packages,import_modules,import_tycons,import_ccalls) = importsBinds topenv binds (importsPrelude emptyImpInfo)
      data_tycons = filter isDataTyCon tycons
\end{code}

%************************************************************************
%*									*
\subsection{Find Imports}
%*									*
%************************************************************************

\begin{code}

importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo
importsBinds env binds = foldR (importsBind env) binds

importsNone :: ImportsInfo -> ImportsInfo
importsNone sofar = sofar

importsBind :: IlxEnv -> StgBinding -> ImportsInfo -> ImportsInfo
importsBind env (StgNonRec _ b rhs) = importsRhs env rhs.importsVar env b
importsBind env (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs env rhs . importsVar env b) pairs

importsRhs :: IlxEnv -> StgRhs -> ImportsInfo -> ImportsInfo
importsRhs env (StgRhsCon _ con args) = importsDataCon env con . importsStgArgs env args
importsRhs env (StgRhsClosure _ _ _ _ args body) = importsExpr env body. importsVars env args

importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo
importsExpr env (StgLit _) = importsNone
importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args
importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args
importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _)) _) args rty)
  = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args
  where 
    (ty_args,tm_args) = splitTyArgs1 args 

importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args


importsExpr env (StgSCC _ expr) = importsExpr env expr
importsExpr env (StgCase scrut _ _ bndr _ alts)
  = importsExpr env scrut. imports_alts alts. importsVar env bndr
   where
    imports_alts (StgAlgAlts _ alg_alts deflt) 	-- The Maybe TyCon part is dealt with 
						-- by the case-binder's type
      = foldR imports_alg_alt alg_alts .  imports_deflt deflt
       where
        imports_alg_alt (con, bndrs, _, rhs)
	  = importsExpr env rhs . importsDataCon env con. importsVars env bndrs

    imports_alts (StgPrimAlts _ alg_alts deflt)
      = foldR imports_prim_alt alg_alts . imports_deflt deflt
       where
        imports_prim_alt (_, rhs) = importsExpr env rhs
    imports_deflt StgNoDefault = importsNone
    imports_deflt (StgBindDefault rhs) = importsExpr env rhs


importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body)
importsExpr env (StgLet bind body)
  = importsBind env bind .  importsExpr env body

importsApp env v args = importsVar env v.  importsStgArgs env args
importsStgArgs env args = foldR (importsStgArg env) args

importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo
importsStgArg env (StgTypeArg ty) = importsType env ty
importsStgArg env (StgVarArg v) = importsVar env v
importsStgArg env _ = importsNone

importsVars env vs = foldR (importsVar env) vs
importsVar env v = importsName env (idName v). importsType env (idType v)

importsName env n
   | isInternalName n = importsNone
   | ilxEnvModule env == nameModule n = importsNone
   | isHomeModule (nameModule n) =  addModuleImpInfo (moduleName (nameModule n))
-- See HACK below
   | isVanillaModule (nameModule n)  && not inPrelude =  importsPrelude
   | isVanillaModule (nameModule n)  && inPrelude =   addModuleImpInfo (moduleName (nameModule n))
-- End HACK
   | otherwise = addPackageImpInfo (modulePackage (nameModule n))


importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
	       | otherwise = addPackageImpInfo basePackage


importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsType env ty = importsType2 env (deepIlxRepType ty)

importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsType2 env (AppTy f x) =  importsType2 env f . importsType2 env x
importsType2 env (TyVarTy _) = importsNone
importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args
importsType2 env (FunTy arg res) =  importsType env arg .  importsType2 env res
importsType2 env (ForAllTy tv body_ty) =  importsType2 env body_ty
importsType2 env (NoteTy _ ty) = importsType2 env ty
importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty"
importsTypeArgs2 env tys = foldR (importsType2 env) tys

importsDataCon env dcon = importsTyCon env (dataConTyCon dcon)

importsTyCon env tc | (not (isDataTyCon tc) || 
                   isInternalName (getName tc) || 
                   ilxEnvModule env == nameModule (getName tc)) = importsNone
importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc .
				    foldR (importsTyConDataCon env) (tyConDataCons tc)


importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo
importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon))

importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty)

importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsTyConDataConType2 env (AppTy f x) =  importsTyConDataConType2 env f . importsTyConDataConType2 env x
importsTyConDataConType2 env (TyVarTy _) = importsNone
importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args
importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg .  importsTyConDataConType2 env res
importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty
importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty
importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty"
importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys

importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || 
                   isInternalName (getName tc) || 
                   ilxEnvModule env == nameModule (getName tc)) = importsNone
importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc)


type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
   -- (Packages, Modules, Datatypes, Imported CCalls)

emptyImpInfo :: ImportsInfo
emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet, emptyUFM)
addPackageImpInfo p (w,x,y,z) = (addOneToUniqSet w p, x, y,z)
addModuleImpInfo m (w,x,y,z) = (w, addOneToUniqSet x m, y,z)
addTyConImpInfo tc (w,x,y,z) = (w, x, addOneToUniqSet y tc,z)
addCCallInfo info@(nm,a,b,c) (w,x,y,z) = (w, x, y,addToUFM z nm info)

ilxImportTyCon :: IlxEnv -> TyCon -> SDoc
ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon
ilxImportTyCon _ _ | otherwise =  empty

ilxImportPackage :: IlxEnv -> PackageName -> SDoc
ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }"

ilxImportModule :: IlxEnv -> ModuleName -> SDoc
ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o")

-- Emit a P/Invoke declaration for the imported C function
-- TODO: emit the right DLL name
ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc
ilxImportCCall env (c,cc,args,ret) = 
    text ".method static assembly pinvokeimpl" <+> 
    parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+> 
    pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+> 
    text "unmanaged preservesig { }"
  where 
    retdoc = 
          if isVoidIlxRepType ret then text "void" 
          else ilxTypeR env (deepIlxRepType ret)


\end{code}

%************************************************************************
%*									*
\subsection{Type declarations}
%*									*
%************************************************************************

\begin{code}


ilxTyCon :: IlxEnv -> TyCon -> SDoc
ilxTyCon env tycon =  ilxTyConDef False env tycon

-- filter to get only dataTyCons?
ilxTyConDef importing env tycon = 
	vcat [empty $$ line,
	      text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text   <+> alts_text]
   where
     tycon_ref =  nameReference env (getName tycon)  <> (ppr tycon)
     super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref)
     tyvars = tyConTyVars tycon
     (ilx_tvs, _) = categorizeTyVars tyvars
     alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs 
     tyvars_text = pprTyVarBinders alts_env ilx_tvs 
     alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon))
     alts_text = nest 2 (braces alts)

pprIlxDataCon env dcon =
        text ".alternative" <+> pprId dcon <+> 
        parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon))))
\end{code}


%************************************************************************
%*									*
\subsection{Getting the .closures and literals out}			*
%************************************************************************

\begin{code}

ilxBindClosures :: IlxEnv -> StgBinding -> SDoc
ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs)
ilxBindClosures env (StgRec _ pairs)  
  = vcat (map (ilxRhsClosures new_env) pairs)
  where
     new_env = extendIlxEnvWithBinds env pairs

---------------
ilxRhsClosures _ (_, StgRhsCon _ _ _)
  = empty

ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs)
  = vcat [ilxExprClosures next_env rhs,

	 empty $$ line,
	 kind_text <+> singleQuotes cloname <+>  free_vs_text,
	 nest 2 (braces (
	    nest 2 (vcat [empty,
                          vcat [text ".apply" <+> closure_sig_text,
                                body_text
                          ],
                          empty
                    ])
                ))
    ]
  where
    kind_of_thing = case upd of
			  Updatable -> ASSERT( null args ) ".thunk"
			  otherwise -> ".closure"
    kind_text = text kind_of_thing 
		
    cloname = ilxEnvQualifyByModule env (ppr bndr)
    next_env = ilxPlaceStgRhsClosure env bndr 
    (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs


    closure_sig_text =     
      vcat [ text "()",
             (case args of 
               []        -> empty
               otherwise -> args_text),
             text "-->" <+>  rty_text]

    (args_text,env_with_args) = pprArgBinders env_with_fvs args

        -- Find the type returned, from the no. of args and the type of "bndr"
    rty_text = 
      case retType env_with_fvs (idIlxRepType bndr) args of
       Just (env,ty) -> 
          if isVoidIlxRepType ty  then  (text "void")
          else ilxTypeR env ty 
       Nothing -> trace "WARNING!  IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> ilxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> ilxTypeR env_with_fvs (idType bndr))

    -- strip off leading ForAll and Fun type constructions
    -- up to the given number of arguments, extending the environment as
    -- we go.  
    retType env ty [] = Just (env, ty)
    retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args
    retType env (FunTy l r) (arg:args) = retType env r args
    retType _ _ _  = Nothing

	-- Code for the local variables
    locals = ilxExprLocals env_with_args rhs

    env_with_locals = extendIlxEnvWithLocals env_with_args locals

	-- Code for the body of the main apply method
    body_code = vcat [empty,
                      pprIlxLocals env_with_args locals,
		      ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return,
                      empty
	        ]

    body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code))


pprIlxLocals env [] = empty
pprIlxLocals env vs 
   = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs))
  where
    nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v)
    nonVoidLocal _ = True

pprIlxLocal env (LocalId v,_) = ilxTypeL env (idIlxRepType v) <+> pprId v
pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = ilxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc


pprFreeBinders env fvs 
    = (ilx_tvs_text <+> vs_text, env2)
    where   
       (free_ilx_tvs, _,free_vs) = categorizeVars fvs
       real_free_vs = filter (not . isVoidIlxRepId) free_vs
        -- ignore the higher order type parameters for the moment
       env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs 
       ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs
       vs_text = parens (pprSepWithCommas ppr_id real_free_vs)
       ppr_id v = ilxTypeL env1 (idIlxRepType v) <+> pprId v 
       env2 = extendIlxEnvWithFreeVars env1 real_free_vs 

pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v)

	-- Declarations for the arguments of the main apply method
pprArgBinders env [] = (empty,env)
pprArgBinders env (arg:args)
    = (arg_text <+> rest_text, res_env)
   where 
     (arg_text,env') = pprArgBinder env arg
     (rest_text,res_env) = pprArgBinders env' args 

-- We could probably omit some void argument binders, but
-- don't...
pprArgBinder env arg 
  | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg])
  | otherwise 
      = if isTyVar arg then 
         let env' = extendIlxEnvWithTyArgs env [arg] in 
         (pprTyVarBinder env' arg, env')
      else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg])

--------------
-- Compute local variables used by generated method.
-- The names of some generated locals are recorded as SDocs.

data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool)  -- flag is for pinning

ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))]
ilxExprLocals env (StgLet bind body) 		  = ilxBindLocals env bind ++ ilxExprLocals env body
ilxExprLocals env (StgLetNoEscape _ _ bind body)  = ilxBindLocals env bind ++ ilxExprLocals env body  -- TO DO????
ilxExprLocals env (StgCase scrut _ _ bndr _ alts) 
     = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ 
       (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ 
       ilxAltsLocals env alts
ilxExprLocals env (StgOpApp (StgFCallOp fcall _) args _) 
     = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
ilxExprLocals _ _  = []

-- Generate locals to use for pinning arguments as we cross the boundary
-- to C.
ilxCCallArgLocals env (StgVarArg v) | pinCCallArg v = 
   [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)]
ilxCCallArgLocals _ _ | otherwise = []

ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))]
ilxBindLocals env (StgRec _ pairs)    = map (\(x,y) -> (LocalId x,Just (env, y))) pairs

ilxAltsLocals env (StgAlgAlts  _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts)
ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts)

ilxAlgAltLocals env (_, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs
ilxPrimAltLocals env (_, rhs)          = ilxExprLocals env rhs

ilxDefltLocals _ StgNoDefault 	= []
ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs

--------------
ilxExprClosures :: IlxEnv -> StgExpr -> SDoc
ilxExprClosures env (StgApp _ args)
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args)  -- get strings
ilxExprClosures env (StgConApp _ args)
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
ilxExprClosures env (StgOpApp _ args _)
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
ilxExprClosures env (StgLet bind body)
  = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
ilxExprClosures env (StgLetNoEscape _ _ bind body)  -- TO DO????
  = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
ilxExprClosures env (StgCase scrut _ _ _ _ alts)
  = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts 
ilxExprClosures env (StgLit lit) 
  = ilxGenLit env lit 
ilxExprClosures _ _ 
  = empty

ilxAltsClosures env (StgAlgAlts _ alts deflt)
  = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs))  <- [1..] `zip` alts]
    $$ 
    ilxDefltClosures env deflt

ilxAltsClosures env (StgPrimAlts _ alts deflt)
  = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts]
    $$ 
    vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts]
    $$ 
    ilxDefltClosures  env deflt

ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs
ilxDefltClosures _ StgNoDefault	  = empty

ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit 
ilxArgClosures _ _ = empty



ilxGenLit env (MachStr fs) 
  = vcat [text ".field static assembly char "  <+> singleQuotes nm <+> text "at" <+> nm <> text "L",
          text ".data" <+> nm <> text "L" <+> text "= char *("  <> pprFSInILStyle fs  <> text ")"
         ]
 where
   nm = ilxEnvQualifyByExact env (text "string")

ilxGenLit  _ _ = empty

\end{code}


%************************************************************************
%*									*
\subsection{Generating code}
%*									*
%************************************************************************


\begin{code}

-- Environment when generating expressions
data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id)

data Sequel = Return | Jump IlxLabel

ilxSequel Return     = text "ret"
ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl

isReturn Return = True
isReturn (Jump _) = False


ilxExpr :: IlxEEnv -> StgExpr 
	-> Sequel 	-- What to do at the end
	-> SDoc

ilxExpr (IlxEEnv env _) (StgApp fun args) sequel
  = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel

-- ilxExpr eenv (StgLit lit) sequel
ilxExpr (IlxEEnv env _) (StgLit lit) sequel
  = pushLit env lit $$ ilxSequel sequel

-- ilxExpr eenv (StgConApp data_con args) sequel
ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel
  = text " /* ilxExpr:StgConApp */ " <+>  ilxConApp env data_con args $$ ilxSequel sequel

-- ilxExpr eenv (StgPrimApp primop args _) sequel
ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel
  = ilxFCall env fcall args ret_ty $$ ilxSequel sequel

ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel
  = ilxPrimOpTable primop args env $$ ilxSequel sequel

--BEGIN TEMPORARY
-- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
-- I think would be subsumed by a general treatmenet of let-no-rec bindings??
ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
              | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
  = ilxExpr eenv rhs sequel
ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
              | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
  = ilxExpr eenv rhs sequel
--END TEMPORARY

ilxExpr eenv (StgLet bind body) sequel
  = ilxBind eenv bind $$ ilxExpr eenv body sequel


ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO???
  = ilxBind eenv bind $$ ilxExpr eenv body sequel

-- StgCase: Special case 1 to avoid spurious branch.
ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in_alts bndr _ alts) sequel
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
	  ilxFunApp (ilxPlaceStgCaseScrut env) fun args False,
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]

-- StgCase: Special case 2 to avoid spurious branch.
ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
	  ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env),
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]

-- StgCase: Normal case.
ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case _live_in_alts bndr _ alts) sequel
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
	  ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl),
	  ilxLabel join_lbl,
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]
  where
    join_lbl = mkJoinLabel bndr

ilxExpr _ _ _ 
  = panic "ilxExpr:  Patterns not matched:(IlxEEnv _ _) (StgSCC _ _) _ (IlxEEnv _ _) (StgLam _ _ _) _"


-- Wipe out locals and arguments that are no longer in use, to
-- prevent space leaks. If the VM is implemented 100% correctly then
-- this should probably not be needed, as the live variable analysis
-- in the JIT would tell the GC that these locals and arguments are
-- no longer live.  However I'm putting it in here so we can
-- check out if it helps.
--
-- Also, in any case this doesn't capture everything we need.  e.g.
-- when making a call:
--     case f x of ...
-- where x is not used in the alternatives, then the variable x
-- is no longer live from the point it is transferred to the call
-- onwards.  We should expunge "live_in_case - live_in_alts" right
-- before making the call, not after returning from the call....
--
-- Strictly speaking we also don't need to do this for primitive
-- values such as integers and addresses, i.e. things not
-- mapped down to GC'able objects.
ilxWipe env ids 
   = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids))

ilxWipeOne env id
   = case lookupIlxVarEnv env id of
	  Just Local  -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id))
	  Just Arg   -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id))
	  Just (CloVar _)  -> ilxComment (text "not yet wiping closure variable" <+> pprId id )
	  _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id )
  where 
      

----------------------

ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc
ilxAlts (IlxEEnv env live) bndr alts sequel
	-- At the join label, the result is on top
	-- of the stack
  = vcat [store_in_bndr,
	  do_case_analysis alts
    ]
  where
    scrut_rep_ty = deepIlxRepType (idType bndr)

    store_in_bndr | isDeadBinder bndr = empty
                  | isVoidIlxRepId bndr 
                        = ilxComment (text "ignoring store of zero-rep value to be analyzed")
		  | otherwise	      = text "dup" $$ (text "stloc" <+> pprId bndr)

    do_case_analysis (StgAlgAlts _ []    deflt)
	= do_deflt deflt

    do_case_analysis (StgAlgAlts _ args deflt) 
        = do_alg_alts ([1..] `zip` args) deflt

    do_case_analysis (StgPrimAlts _ alts deflt)
	= do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt

    do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con
      -- Collapse the analysis of unboxed tuples where 
      -- some or all elements are zero-sized
      --
      -- TO DO: add bndrs to set of live variables
          = case bndrs' of
                  [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs
                  _ -> bind_components alt_env dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs
           where 
            bndrs' = filter (not. isVoidIlxRepId) bndrs
            -- Replacement unboxed tuple type constructor, used if any of the
            -- arguments have zero-size and more than one remains.
            dcon'  = tupleCon Unboxed (length bndrs')

            alt_env = IlxEEnv (ilxPlaceAlt env i) live
            --alt_env = IlxEEnv (ilxPlaceAlt env i) 

            bind_collapse [] _ = panic "bind_collapse: unary element not found"
            bind_collapse (h:t) (is_used:used_flags) 
                | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags)
	        | not is_used = ilxComment (text "not used") <+> text "pop"
                | otherwise = text "stloc" <+> pprId h


    do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault 
            = vcat [text "castdata" <+> sep [ilxTypeR env scrut_rep_ty <> comma,
		  			     ilxConRef env data_con],
 		do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt
	      ]

    do_alg_alts alts deflt
	= vcat [text "datacase" <+> sep [ilxTypeR env scrut_rep_ty,text ",",
					 pprSepWithCommas pp_case labels_w_alts],
		do_deflt deflt,
		vcat (map do_labelled_alg_alt labels_w_alts)
	  ]
	where
	  pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl)
	  labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts]

    do_prim_alts [] = empty
    do_prim_alts ((i, (lit,alt)) : alts) 
	= vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl, 
		do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt, 
		ilxLabel lbl, do_prim_alts alts]
	where
	  lbl = mkAltLabel bndr i

    do_labelled_alg_alt (i,(lbl, alt)) 
        = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt

    do_alg_alt alt_eenv (data_con, bndrs, used_flags, rhs) 
      = vcat [bind_components alt_eenv data_con bndrs 0 used_flags,
	      do_rhs alt_eenv rhs
	     ]

    bind_components alt_eenv data_con [] n _ = empty
    bind_components alt_eenv data_con (h:t) n (is_used:used_flags) 
       | isVoidIlxRepId h 
             -- don't increase the count in this case
             = ilxComment (text "zero-rep binding eliminated") 
               <+> bind_components alt_eenv data_con t n used_flags
       | otherwise 
             = bind_component alt_eenv data_con h is_used n 
               <+> bind_components alt_eenv data_con t (n + 1) used_flags

    bind_component alt_eenv@(IlxEEnv alt_env _) data_con bndr is_used reduced_fld_no 
	| not is_used 
            = ilxComment (text "not used")
        | isVoidIlxRepId bndr 
            = ilxComment (text "ignoring bind of zero-rep variable")
	| otherwise   = vcat [text "dup",
			      ld_data alt_env data_con reduced_fld_no bndr,
			      text "stloc" <+> pprId bndr]

    do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs
    do_deflt StgNoDefault 	  = empty

    do_rhs alt_eenv rhs  
        | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs     -- void on the stack, nothing to pop
        | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs  -- drop the value

    do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel

    ld_data alt_env data_con reduced_fld_no bndr
      | isUnboxedTupleCon data_con
      = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no,
			      ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no]
      | otherwise 
      = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, 
		               ilxConRef env data_con <> comma,
			       integer reduced_fld_no]


-------------------------

ilxBestTermArity = 3
ilxBestTypeArity = 7


-- Constants of unlifted types are represented as
-- applications to no arguments.
ilxFunApp env fun [] _ | isUnLiftedType (idType fun)
  = pushId env fun

ilxFunApp env fun args tail_call 
  =	-- For example:
        --	ldloc f		function of type forall a. a->a
	--	ldloc x		arg of type Int
	--	.tail callfunc <Int32> (!0) --> !0
	--
    vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call]

ilxFunAppAfterPush env fun args tail_call 
  =	-- For example:
        --	ldloc f		function of type forall a. a->a
	--	ldloc x		arg of type Int
	--	.tail callfunc <Int32> (!0) --> !0
	--
    vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
  where
    known_clo :: KnownClosure
    known_clo =
      case lookupIlxBindEnv env fun of
	  Just (_, StgRhsClosure  _ _ _ Updatable _ _)   -> Nothing 
	  Just (place, StgRhsClosure  _ _ fvs _ args _)  -> Just (place,fun,args,fvs)
	  _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun))

type KnownClosure = Maybe (  IlxEnv	-- Of the binding site of the function
			   , Id		-- The function
			   , [Var]	-- Binders
			   , [Var])	-- Free vars of the closure

-- Push as many arguments as ILX allows us to in one go, and call the function
-- Recurse until we're done.
-- The function is already on the stack
ilxFunAppArgs :: IlxEnv
	      -> Int		-- Number of args already pushed (zero is a special case;
				--	otherwise used only for place generation)
	      -> Type		-- Type of the function
	      -> [StgArg]	-- The arguments
	      -> Bool		-- True <=> tail call please
	      -> KnownClosure	-- Information about the function we're calling
	      -> SDoc

ilxFunAppArgs env num_sofar funty args tail_call known_clo
 =   vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
	   call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty)
                     <+> now_args_text
                     <+> text "-->" 
                     <+> later_ty_text,
           later
          ]
  where
    now_args_text = 
      case now_arg_tys of
        [] -> empty
        _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)

    later_ty_text
        | isVoidIlxRepType later_ty = text "void"
        | otherwise = ilxTypeR env_after_now_tyvs later_ty

    (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = 
	case args of
          (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty
          _ -> get_term_args 0 ilxBestTermArity args env funty

     -- Only apply up to maxArity real (non-type) arguments
     -- at a time.  ILX should, in principle, allow us to apply
     -- arbitrary numbers, but you will get more succinct 
     -- (and perhaps more efficient) IL code
     -- if you apply in clumps according to its maxArity setting.
     -- This is because it has to unwind the stack and store it away
     -- in local variables to do the partial applications.
     --
     -- Similarly, ILX only allows one type application at a time, at
     -- least until we implement unwinding the stack for this case.
     --
     -- NB: In the future we may have to be more careful 
     -- all the way through 
     -- this file to bind type variables as we move through
     -- type abstractions and "forall" types.  This would apply
     -- especially if the type variables were ever bound by expressions
     -- involving the type variables.  

    -- This part strips off at most "max" term applications or one type application
    get_type_args 0 args env funty = ([],[],env,args,funty)
    get_type_args max args env (NoteTy _ ty) = 
          trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty)
    get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty) 
        = if isIlxTyVar tv then 
            let env2 = extendIlxEnvWithFormalTyVars env [tv] in 
            let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in 
            let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in 
            let arg_ty = mkTyVarTy tv in 
            (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
          else 
             get_type_args max rest env rem_funty  -- ? subst??
    get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty)
    get_type_args _ args env funty = ([],[],env,args,funty)

    get_term_args n max args env (NoteTy _ ty)
       -- Skip NoteTy types 
       = trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args n max args env ty)
    get_term_args n 0 args env funty
       -- Stop if we've hit the maximum number of ILX arguments to apply n one hit.
       = ([],[],env,args,funty)
    get_term_args n max args env funty
      | (case known_clo of
           Just (_,_,needed,_) -> needed `lengthIs` n
           Nothing -> False)
       -- Stop if we have the optimal number for a direct call
       = ([],[],env,args,funty)
    get_term_args _ _ (args@(StgTypeArg _:_)) env funty 
       -- Stop if we hit a type arg.
       = ([],[],env,args,funty)
    get_term_args n max (h:t) env (FunTy dom ran)
       -- Take an argument.
       = let (now,now_tys,env2,later,later_ty) = get_term_args (n+1) (max - 1) t env ran in 
         (h:now, (h,dom):now_tys,env2,later,later_ty)
    get_term_args _ max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty)
    get_term_args _ max args env funty = ([],[],env,args,funty)

    -- Are there any remaining arguments?
    done  = case later_args of
          [] -> True
          _ -> False

    -- If so, generate the subsequent calls.
    later = if done then text "// done"  
            else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing

    -- Work out whether to issue a direct call a known closure (callclo) or
    -- an indirect call (callfunc).  Basically, see if the identifier has
    -- been let-bound, and then check we are applying exactly the right 
    -- number of arguments.  Also check that it's not a thunk (actually, this
    -- is done up above).
    -- 
    -- The nasty "all" check makes sure that 
    -- the set of type variables in scope at the callsite is a superset 
    -- of the set of type variables needed for the direct call.  This is
    -- is needed because not all of the type variables captured by a 
    -- let-bound binding will get propogated down to the callsite, and 
    -- the ILX system of polymorphism demands that the free type variables
    -- get reapplied when we issue the direct "callclo".  The
    -- type variables are in reality also "bound up" in the closure that is
    -- passed as the first argument, so when we do an indirect call
    -- to that closure we're fine, which is why we don't need them in 
    -- the "callfunc" case.
    basic_call_instr =
      case known_clo of
        Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && 
                                          all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> 
           vcat [text "callclo class",
                 nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)),
                 pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)]
           <> text ","
          where 
           (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
        otherwise -> text "callfunc"
    call_instr =
           if (tail_call && done) then text "tail." <+> basic_call_instr
	   else basic_call_instr


--------------------------
-- Print the arg info at the call site
-- For type args we are, at the moment, required to
-- give both the actual and the formal (bound).  The formal
-- bound is always System.Object at the moment (bounds are
-- not properly implemented in ILXASM in any case, and nor do
-- we plan on making use og them) For
-- non-type args the actuals are on the stack, and we just give the
-- formal type.
pprIlxArgInfo env (StgTypeArg  arg,ty) =  
    angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "<class [mscorlib] System.Object>" 
pprIlxArgInfo env (_,ty) =  
    parens (ilxTypeL env ty)


----------------------------
-- Code for a binding
ilxBind :: IlxEEnv -> StgBinding -> SDoc
ilxBind eenv@(IlxEEnv env _) bind = 
    vcat [vcat (map (ilxRhs env rec) pairs), 
          vcat (map (ilxFixupRec env rec) pairs)]
       where 
         rec = ilxRecIds1 bind
         pairs = ilxPairs1 bind


----------------------------
-- Allocate a closure or constructor.  Fix up recursive definitions.
ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc

ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr  
  = empty

ilxRhs env rec (bndr, StgRhsCon _ con args)
  = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args,
	   text "stloc" <+> pprId bndr
          ]

ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
  = 	-- Assume .closure v<any A>(int64,!A) { 
	--		.apply <any B> (int32) (B) { ... }
	--	   }
	-- Then
        --    let v = \B (x:int32) (y:B). ... 
        -- becomes:
        --    newclo v<int32>(int64,!0)
	--    stloc v
    vcat [vcat (map pushFv free_vs),
          (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non-verifiable"))),
	  text "newclo" <+> clotext,
	  text "stloc" <+> pprId bndr
    ]
  where
    pushFv id = if elem id rec then text "ldnull" else pushId env id
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
    clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)

ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id")

ilxFixupRec env rec (bndr, StgRhsCon _ con args)
  = text "// no recursive fixup"

ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
     = vcat [vcat (map fixFv rec)]
  where
    fixFv recid = if elem recid fvs then 
                    vcat [pushId env bndr,
                          pushId env recid,
                          text "stclofld" <+> clotext <> text "," <+> pprId recid] 
                else text "//no fixup needed for" <+> pprId recid
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
    clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)



---------------------------------------------
-- Code for a top-level binding in a module
ilxPairs binds = concat (map ilxPairs1 binds)

ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)]
ilxPairs1 (StgRec _ pairs)       = pairs

ilxRecIds1 (StgNonRec _ bndr rhs) = []
ilxRecIds1 (StgRec _ pairs)       = map fst pairs

---------------------------------------------
-- Code for a top-level binding in a module
-- TODO: fix up recursions amongst CAF's
-- e.g. 
--    x = S x
-- for infinity...
-- 
-- For the moment I've put in a completely spurious "reverse"...
--
-- Consider: make fixing up of CAF's part of ILX?  i.e.
-- put static, constant, allocated datastructures into ILX. 

stableSortBy :: (a -> a -> Ordering) -> [a] -> [a]
stableSortBy f (h:t) = insertBy f h (stableSortBy f t)
stableSortBy f [] = []

usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering
usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT
usedBy (m,_) (n,_) | m == n = EQ
usedBy (m,_) (_,_) = GT

isArg m  (StgVarArg n) = (n == m)
isArg m _ = False


ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc
--ilxTopBind mod env (StgNonRec _ bndr rhs) = 
--ilxTopRhs env (bndr,rhs)
ilxTopBind mod env pairs       = 
   vcat [text ".class" <+> pprId mod,
         nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))]
     where
       cctor = vcat [text ".method static rtspecialname specialname void .cctor()",
                     nest 2 (braces 
                      (nest 2 (vcat [text ".maxstack 100",
			             text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
                                     vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)), 
			             text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
                                     text "ret",
                                     empty])))]
       flds =   vcat (map (ilxTopRhsStorage mod env) pairs)

--ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr 
--  = empty

ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs)
  = vcat [vcat (map (pushId env) free_vs),
         (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
	  text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
	  text "stsfld"  <+> pprFieldRef env (mod,bndTy,bndr)
    ]
  where
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
    bndTy = idIlxRepType bndr

ilxTopRhs mod env (bndr, StgRhsCon _ data_con args)
  = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args, 
	   text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
    ]
  where
    bndTy = idIlxRepType bndr

pprFieldRef env (mod,ty,id) 
  =  ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id

ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) 
  =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
  where
    bndTy = idIlxRepType bndr
ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) 
  =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
  where
    bndTy = idIlxRepType bndr

--------------------------------------
-- Push an argument
pushArgWithVoids =  pushArg_aux True
pushArg = pushArg_aux False

pushArg_aux voids env (StgTypeArg ty) = empty
pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var
pushArg_aux voids env (StgLitArg lit) = pushLit env lit


mapi f l = mapi_aux f l 0

mapi_aux f [] n = []
mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1)

--------------------------------------
-- Push an Id
pushId = pushId_aux False

pushId_aux :: Bool -> IlxEnv -> Id -> SDoc
pushId_aux voids _ id | isVoidIlxRepId id =
   /* if voids then  text "ldunit" else */ ilxComment (text "pushId: void rep skipped")
pushId_aux _ env var 
  = case lookupIlxVarEnv env var of
	  Just Arg    -> text "ldarg"    <+> pprId var
	  Just (CloVar n) -> text "ldenv" <+> int n
	  Just Local  -> text "ldloc"    <+> pprId var
	  Just (Top m)  -> 
             vcat [ilxComment (text "pushId (Top) " <+> pprId m), 
                   text "ldsfld" <+> ilxTypeL env (idIlxRepType var)
                      <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var]

	  Nothing ->  
             vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), 
                   text "ldsfld" <+> ilxTypeL env (idIlxRepType var) 
                    <+> pprIlxTopVar env var]

--------------------------------------
-- Push a literal
pushLit env (MachChar c)   = text "ldc.i4" <+> int c
pushLit env (MachStr s)    = text "ldsflda char "  <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s 
pushLit env (MachInt i)    = text "ldc.i4" <+> integer i
pushLit env (MachInt64 i)  = text "ldc.i8" <+> integer i
pushLit env (MachWord w)   = text "ldc.i4" <+> integer w <+> text "conv.u4"
pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8"
pushLit env (MachFloat f)  = text "ldc.r4" <+> rational f
pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!!  Not valid in ILX!!")
pushLit env (MachNullAddr)  = text "ldc.i4 0"
pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!!  Not valid in ILX!!")

pprIlxTopVar env v
  | isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
  | otherwise	   = pprId (nameOccName n)
  where
    n = idName v

\end{code}


%************************************************************************
%*									*
\subsection{Printing types}
%*									*
%************************************************************************


\begin{code}

isVoidIlxRepType (NoteTy   _ ty) = isVoidIlxRepType ty
isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
isVoidIlxRepType (TyConApp tc tys) 
  = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys)
isVoidIlxRepType _ = False

isVoidIlxRepId id = isVoidIlxRepType (idType id)



-- Get rid of all NoteTy and NewTy artifacts
deepIlxRepType :: Type -> Type
deepIlxRepType (FunTy l r)
  = FunTy (deepIlxRepType l) (deepIlxRepType r)

deepIlxRepType ty@(TyConApp tc tys) 
  =        -- collapse UnboxedTupleTyCon down when it contains VoidRep types.
	   -- e.g. 	(# State#, Int#, Int# #)  ===>   (# Int#, Int# #)
            if isUnboxedTupleTyCon tc then 
               let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in 
               case tys' of
                  [h] -> h
                  _ -> mkTupleTy Unboxed (length tys') tys'
            else 
              TyConApp tc (map deepIlxRepType tys)
deepIlxRepType (AppTy f x)     = AppTy (deepIlxRepType f) (deepIlxRepType x)
deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
deepIlxRepType (NoteTy   _ ty) = deepIlxRepType ty
deepIlxRepType (SourceTy p)    = deepIlxRepType (sourceTypeRep p)
deepIlxRepType ty@(TyVarTy tv) = ty

idIlxRepType id = deepIlxRepType (idType id)

--------------------------
-- Some primitive type constructors are not thunkable.
-- Everything else needs to be marked thunkable.
ilxTypeL :: IlxEnv -> Type -> SDoc

ilxTypeL env ty | isUnLiftedType ty ||  isVoidIlxRepType ty = ilxTypeR env ty
ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty)


--------------------------
-- Print non-thunkable version of type.
--

ilxTypeR :: IlxEnv -> Type -> SDoc
ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */"
ilxTypeR env ty@(AppTy f _) | isTyVarTy f    = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object")
ilxTypeR env ty@(AppTy f x)     = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types?!") <+> ilxTypeR env (applyTy f x))
ilxTypeR env (TyVarTy tv)       = ilxTyVar env tv

-- The following is a special rule for types constructed out of 
-- higher kinds, e.g. Monad f or Functor f.  
--
-- The code below is not as general as it should be, but as I
-- have no idea if this approach will even work, I'm going to
-- just try it out on some simple cases arising from the prelude.
ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
   = ilxComment (text "what on earth? 2") <+> (ilxTypeR env (TyConApp tc t))
ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
   = ilxTypeR env (TyConApp tc t)
ilxTypeR env (TyConApp tc args) = ilxTyConApp env tc args

  -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes 
  -- is on the left of an arrow
  --  We could probably eliminate all but a final occurrence of these.
ilxTypeR env (FunTy arg res)| isVoidIlxRepType res 
    = pprIlxFunTy (ilxTypeL env arg) (text "void")
ilxTypeR env (FunTy arg res)
    = pprIlxFunTy (ilxTypeL env arg) (ilxTypeR env res)

ilxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
  = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (ilxTypeR env' body_ty))
    where
       env' = extendIlxEnvWithFormalTyVars env [tv]

ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise
  = ilxComment (text "higher order type var " <+> pprId tv) <+>
    pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty)

ilxTypeR env (NoteTy _ ty)       
   = trace "WARNING! non-representation type given to ilxTypeR: see generated ILX for context where this occurs"
     (vcat [text "/* WARNING! non-representation type given to ilxTypeR! */",
           ilxTypeR env ty ])

pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])

ilxTyConApp env tcon args =
   case lookupUFM tyPrimConTable (getUnique tcon) of
	Just f  -> f args env
        Nothing -> 
            (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp)
              env tcon args

pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon
pprIlxUnboxedTupleTyConApp env tcon args 
  = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void
  where 
   non_void = filter (not . isVoidIlxRepType) args
   tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) 
pprIlxBoxedTyConApp env tcon args 
  = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args
pprIlxNamedTyConApp env tcon_text args 
  = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args

-- Returns e.g: <Int32, Bool>
-- Void-sized type arguments are _always_ eliminated, everywhere.
-- If the type constructor is an unboxed tuple type then it should already have
-- been adjusted to be the correct constructor.
pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys)

pprTypeArgs_aux f env []  = empty
pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys)


pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc
-- Returns e.g: <class [mscorlib]System.Object> <class [mscorlib]System.Object>
-- plus a new environment with the type variables added.
pprTyVarBinders env [] = empty
pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs)

pprTyVarBinder :: IlxEnv -> TyVar -> SDoc
pprTyVarBinder env tv = 
    if isIlxTyVar tv then 
       angleBrackets (pprTyVarBinder_aux env tv)
    else
       ilxComment (text "higher order tyvar" <+> pprId tv <+> 
                         text ":" <+> ilxTypeR env (tyVarKind tv)) <+>
             ilxComment (text "omitted")
             -- parens (text "class [mscorlib]System.Object" <+> pprId tv)


pprTyVarBinder_aux env tv = 
   ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> 
                        ilxTypeR env (tyVarKind tv)) <+>
             (text "class [mscorlib]System.Object")

-- Only a subset of Haskell types can be generalized using the type quantification
-- of ILX
isIlxForAllKind h = 
        ( h `eqKind` liftedTypeKind) ||
        ( h `eqKind` unliftedTypeKind) ||
        ( h `eqKind` openTypeKind)

isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v)

categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs)
         where
           (tvs, vs) = partition isTyVar fvs
           (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs

categorizeTyVars tyvs = partition isIlxTyVar tyvs

pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys)

pprId id = singleQuotes (ppr id)

\end{code}			

%************************************************************************
%*									*
\subsection{IlxEnv}	
%*									*
%************************************************************************

\begin{code}
type IlxTyEnv = [TyVar]
emptyIlxTyEnv = []

-- Nb. There is currently no distinction between the kinds of type variables.
-- We may need to add this to print out correct numbers, esp. for
-- "forall" types
extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters
extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type
extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type

formalIlxTyEnv tyvars = mkIlxTyEnv tyvars
mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ]

data HowBound = Top Module 	-- Bound in a modules
	      | Arg	-- Arguments to the enclosing closure
	      | CloVar Int -- A free variable of the enclosing closure
                           -- The int is the index of the field in the 
                           -- environment
	      | Local	-- Local let binding

-- The SDoc prints a unique name for the syntactic block we're currently processing,
-- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo.
data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool)
type Place = (SDoc,SDoc)

ilxTyVar  env tv
  = go 0 (ilxEnvTyEnv env)
  where
    go n [] 		    
      = pprTrace "ilxTyVar" (pprId tv <+> text "tv_env = { "
           <+> pprSepWithCommas
	         (\x -> pprId x <+> text ":" <+> ilxTypeR env (tyVarKind x)) 
               (ilxEnvTyEnv env) <+> text "}") 
        (char '!' <> pprId tv) 
    go n (x:xs)
      = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -}
        (if tyVarName x== tyVarName tv then  char '!' <> int n <+> ilxComment (char '!' <> pprId tv) 
         else go (n+1) xs)

emptyIlxEnv :: Bool -> Module -> IlxEnv
emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace)

nextPlace place sdoc = place <> sdoc
usePlace  place sdoc = place <> sdoc

ilxEnvModule (IlxEnv (m, _, _,  _, _,_)) = m
ilxEnvSetPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
   = IlxEnv (m, tv_env, id_env,  bind_env, (mod, sdoc),tr)
ilxEnvNextPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
   = IlxEnv (m, tv_env, id_env,  bind_env, (mod, nextPlace exact sdoc),tr)
ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc
ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc

ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D")
ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique
ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S")

ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv
ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i)
ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i)
ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ]
ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ]

extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv
extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
  = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv      | tv <- args, isIlxTyVar tv],
            extendVarEnvList id_env [(v,Arg) | v  <- args, not (isIlxTyVar v)], 
	     bind_env, place,tr)

extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
  = IlxEnv (mod, 
            extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv],
            extendVarEnvList id_env (clovs 0 args), 
            bind_env, 
            place,tr)
   where
     clovs _ [] = []
     clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs

extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds
  = IlxEnv (mod, tv_env, id_env, 
            extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds], 
            place,tr)

extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals
  = IlxEnv (m, tv_env, 
            extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals],
            extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals], 
            p,tr)
extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds
  = IlxEnv (m, tv_env, 
            extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds], 
            extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds], 
            place,tr)

formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars 
  = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr)

ilxEnvTyEnv :: IlxEnv -> IlxTyEnv
ilxEnvTyEnv (IlxEnv (_, tv_env, _,_,_,_)) = tv_env 
elemIlxTyEnv var env = elem var (ilxEnvTyEnv env )
elemIlxVarEnv var (IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env 
lookupIlxVarEnv (IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var
lookupIlxBindEnv (IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var

\end{code}


\begin{code}
type IlxLabel = SDoc

pprIlxLabel lbl = lbl

mkJoinLabel :: Id -> IlxLabel
mkJoinLabel v = text "J_" <> ppr v

mkAltLabel  :: Id -> Int -> IlxLabel
mkAltLabel v n = text "A" <> int n <> ppr v

ilxLabel :: IlxLabel -> SDoc
ilxLabel lbl =  line $$ (pprIlxLabel lbl <> colon)
\end{code}


%************************************************************************
%*									*
\subsection{Local pretty helper functions}
%*									*
%************************************************************************

\begin{code}
pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc
pprSepWithCommas pp xs = sep (punctuate comma (map pp xs))
ilxComment pp   = text "/*" <+> pp <+> text "*/"
singleQuotes pp = char '\'' <> pp <> char '\''

line = text "// ----------------------------------"

hscOptionQual = text ".i_"

nameReference env n
  | isInternalName n = empty
  | ilxEnvModule env == nameModule n  = text ""
  | isHomeModule (nameModule n)   = moduleNameReference (moduleName (nameModule n))
-- HACK: no Vanilla modules should be around, but they are!!  This
-- gets things working for the scenario "standard library linked as one
-- assembly with multiple modules + a one module program running on top of this"
-- Same applies to all other mentions of Vailla modules in this file
  | isVanillaModule (nameModule n)  && not inPrelude =  basePackageReference
  | isVanillaModule (nameModule n)  && inPrelude =   moduleNameReference (moduleName (nameModule n))
-- end hack
  | otherwise = packageReference (modulePackage (nameModule n))

packageReference p = brackets (singleQuotes (ppr p  <> hscOptionQual))
moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o")))

moduleReference env m
  | ilxEnvModule env   == m = text ""
  | isHomeModule m = moduleNameReference (moduleName m)
  -- See hack above
  | isVanillaModule m && not inPrelude =  basePackageReference
  | isVanillaModule m && inPrelude =  moduleNameReference (moduleName m)
  -- end hack
  | otherwise  =  packageReference (modulePackage m)

basePackageReference = packageReference basePackage
inPrelude = basePackage == opt_InPackage

------------------------------------------------
-- This code is copied from absCSyn/CString.lhs,
-- and modified to do the correct thing!  It's
-- still a mess though.  Also, still have to do the
-- right thing for embedded nulls.

pprFSInILStyle :: FastString -> SDoc
pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs)))

stringToC   :: String -> String
-- Convert a string to the form required by C in a C literal string
-- Tthe hassle is what to do w/ strings like "ESC 0"...
stringToC ""  = ""
stringToC [c] = charToC c
stringToC (c:cs)
    -- if we have something "octifiable" in "c", we'd better "octify"
    -- the rest of the string, too.
  = if (c < ' ' || c > '~')
    then (charToC c) ++ (concat (map char_to_C cs))
    else (charToC c) ++ (stringToC cs)
  where
    char_to_C c | c == '\n' = "\\n"	-- use C escapes when we can
		| c == '\a' = "\\a"
		| c == '\b' = "\\b"	-- ToDo: chk some of these...
		| c == '\r' = "\\r"
		| c == '\t' = "\\t"
		| c == '\f' = "\\f"
		| c == '\v' = "\\v"
		| otherwise = '\\' : (trigraph (ord c))

charToC :: Char -> String
-- Convert a character to the form reqd in a C character literal
charToC c = if (c >= ' ' && c <= '~')	-- non-portable...
	    then case c of
		  '\'' -> "\\'"
		  '\\' -> "\\\\"
		  '"'  -> "\\\""
		  '\n' -> "\\n"
		  '\a' -> "\\a"
		  '\b' -> "\\b"
		  '\r' -> "\\r"
		  '\t' -> "\\t"
		  '\f' -> "\\f"
		  '\v' -> "\\v"
		  _    -> [c]
	    else '\\' : (trigraph (ord c))

trigraph :: Int -> String
trigraph n
  = [chr ((n `div` 100) `rem` 10 + ord '0'),
     chr ((n `div` 10) `rem` 10 + ord '0'),
     chr (n `rem` 10 + ord '0')]


\end{code}

%************************************************************************
%*									*
\subsection{PrimOps and Constructors}
%*									*
%************************************************************************

\begin{code}
----------------------------
-- Allocate a fresh constructor

ilxConApp env data_con args
  | isUnboxedTupleCon data_con
     = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in 
       case tm_args' of
        [h] -> 
          -- Collapse the construction of an unboxed tuple type where
          -- every element is zero-sized
            vcat (ilxMapPlaceArgs 0 pushArg env tm_args')
        _ -> 
          -- Minimize the construction of an unboxed tuple type, which
          -- may contain zero-sized elements.  Recompute all the 
          -- bits and pieces from the simpler case below for the new data
          -- type constructor....
           let data_con' = tupleCon Unboxed (length tm_args') in 
           let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in 

           let tycon' = dataConTyCon data_con' in
           let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in 
           let (formal_arg_tys', _)     = splitFunTys formal_tau_ty' in
           let formal_env' 	     = formalIlxEnv env formal_tyvars' in 

           vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'),
	           sep [text "newobj void ",
  		        ilxTyConApp env tycon' rep_ty_args',
                        text "::.ctor",
                        pprValArgTys ilxTypeR formal_env' (map deepIlxRepType formal_arg_tys')
	           ]
             ]
 | otherwise
    -- Now all other constructions
     =	--  Assume C :: forall a. a -> T a -> T a
   	--	ldloc x		arg of type Int
	--	ldloc y		arg of type T Int
	-- 	newdata classunion T<Int32>, C(!0, T <!0>)
	--
        let tycon   = dataConTyCon data_con in 
        let (formal_tyvars, formal_tau_ty) = splitForAllTys (dataConRepType data_con) in
        let (formal_arg_tys, _)     = splitFunTys formal_tau_ty in 

       vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args),
	  sep [	text "newdata",
		nest 2 (ilxTyConApp env tycon rep_ty_args <> comma),
		nest 2 (ilxConRef env data_con)
	  ]
        ]
 where
   tycon   = dataConTyCon data_con 
   rep_ty_args = map deepIlxRepType ty_args
   (ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args  else splitTyArgs1 args

-- Split some type arguments off, throwing away the higher kinded ones for the moment.
-- Base the higher-kinded checks off a corresponding list of formals.
splitTyArgs :: [Var] 		-- Formals
	    -> [StgArg]		-- Actuals
	    -> ([Type], [StgArg])
splitTyArgs (htv:ttv) (StgTypeArg h:t) 
   | isIlxTyVar htv = ((h:l), r) 
   | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r) 
   where (l,r) = splitTyArgs ttv t 
splitTyArgs _ l = ([],l)
 
-- Split some type arguments off, where none should be higher kinded
splitTyArgs1 :: [StgArg] -> ([Type], [StgArg])
splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args')
				    where
				      (tys, args') = splitTyArgs1 args
splitTyArgs1 args		    = ([], args)

ilxConRef env data_con
 | isUnboxedTupleCon data_con
    = let data_con' = tupleCon Unboxed (length non_void_args)in 
      pprId data_con' <> arg_text
 | otherwise 
    = pprId data_con <> arg_text
  where
    arg_text = pprValArgTys ilxTypeL env' (map deepIlxRepType non_void_args)
    non_void_args = filter (not . isVoidIlxRepType) arg_tys
    (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con)
    (arg_tys, _)     = splitFunTys tau_ty
    env' 	     = formalIlxEnv env tyvars




\end{code}


%************************************************************************
%*									*
\subsection{PrimOps and Prim Representations}				*
%************************************************************************

\begin{code}

ilxPrimApp env op 	       args ret_ty = ilxPrimOpTable op args env


type IlxTyFrag = IlxEnv -> SDoc
ilxType s env = text s

ilxLift ty env = text "thunk" <> angleBrackets (ty env)

ilxTypeSeq :: [IlxTyFrag] -> IlxTyFrag
ilxTypeSeq ops env = hsep (map (\x -> x env) ops)

tyPrimConTable :: UniqFM ([Type] -> IlxTyFrag)
tyPrimConTable = 
  listToUFM [(addrPrimTyConKey, 	(\_ -> repAddr)),
--	     (fileStreamPrimTyConKey, 	(\_ -> repFileStream)),
	     (foreignObjPrimTyConKey, 	(\_ -> repForeign)),
             (stablePtrPrimTyConKey, 	(\[ty] -> repStablePtr {- (ilxTypeL2 ty) -})),
             (stableNamePrimTyConKey, 	(\[ty] -> repStableName {- (ilxTypeL2 ty) -} )),
             (charPrimTyConKey, 	(\_ -> repChar)),
	     (wordPrimTyConKey, 	(\_ -> repWord)),
	     (byteArrayPrimTyConKey,	(\_ -> repByteArray)),
	     (intPrimTyConKey, 	        (\_ -> repInt)),
	     (int64PrimTyConKey,	(\_ -> repInt64)),
	     (word64PrimTyConKey,	(\_ -> repWord64)),
	     (floatPrimTyConKey, 	(\_ -> repFloat)),
	     (doublePrimTyConKey,	(\_ -> repDouble)),
              -- These can all also accept unlifted parameter types so we explicitly lift.
	     (arrayPrimTyConKey, 	(\[ty] -> repArray (ilxTypeL2 ty))),
	     (mutableArrayPrimTyConKey, 	(\[_, ty] -> repMutArray (ilxTypeL2 ty))),
	     (weakPrimTyConKey, 	(\[ty] -> repWeak (ilxTypeL2 ty))),
	     (mVarPrimTyConKey, 	(\[_, ty] -> repMVar (ilxTypeL2 ty))),
	     (mutVarPrimTyConKey, 	(\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))),
	     (mutableByteArrayPrimTyConKey,	(\_ -> repByteArray)),
	     (threadIdPrimTyConKey,	(\_ -> repThread)),
	     (bcoPrimTyConKey,	(\_ -> repBCO))
	     ]

ilxTypeL2 :: Type -> IlxTyFrag
ilxTypeL2 ty env = ilxTypeL env ty
ilxTypeR2 :: Type -> IlxTyFrag
ilxTypeR2 ty env = ilxTypeR env ty

ilxMethTyVarA = ilxType "!!0"
ilxMethTyVarB = ilxType "!!1"
prelGHCReference :: IlxTyFrag
prelGHCReference env =
   if ilxEnvModule env == mkHomeModule (mkModuleName "PrelGHC") then empty
   else if inPrelude then moduleNameReference (mkModuleName "PrelGHC")
   else basePackageReference

prelBaseReference :: IlxTyFrag
prelBaseReference env =
   if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty
   else if inPrelude then moduleNameReference (mkModuleName "PrelBase")
   else basePackageReference

repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ "
repByteArray = ilxType "unsigned int8[] /* ByteArr# */ "
--repFileStream = text "void * /* FileStream# */ "  -- text "class [mscorlib]System.IO.FileStream"
repInt = ilxType "int32"
repWord = ilxType "unsigned int32"
repAddr =ilxType "/* Addr */ void *"
repInt64 = ilxType "int64"
repWord64 = ilxType "unsigned int64"
repFloat = ilxType "float32"
repDouble = ilxType "float64"
repChar = ilxType "/* Char */ unsigned int8"
repForeign = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Foreignzh"]
repInteger = ilxUnboxedPairRep repInt repByteArray
repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray
repArray ty = ilxTypeSeq [ty,ilxType "[]"]
repMutArray ty = ilxTypeSeq [ty,ilxType "[]"]
repMVar ty = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MVarzh",ilxTyParams [ty]]
repMutVar _ ty2 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MutVarzh",ilxTyParams [ty2]]
repWeak ty1 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh",ilxTyParams [ty1]]
repStablePtr {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StablePtrzh" {- ,ilxTyParams [ty1] -} ]
repStableName {- ty1 -}  = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StableNamezh" {- ,ilxTyParams [ty1] -} ]
classWeak = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh"]
repBCO = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_BCOzh"]

ilxTyPair l r = ilxTyParams [l,r]
ilxTyTriple l m r = ilxTyParams [l,m,r]
ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r]
ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H"]
ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyPair l r]
ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyTriple l m r]
ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z4H",ilxTyQuad l m1 m2 r]

ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"]

ilxTyParams :: [IlxTyFrag] -> IlxTyFrag
ilxTyParams [] env = empty
ilxTyParams l env = angleBrackets (ilxTyParamsAux l env)
  where
   ilxTyParamsAux [] env = empty
   ilxTyParamsAux [h] env = h env
   ilxTyParamsAux (h:t) env = h env <> text "," <+> ilxTyParamsAux t env
   ilxTyParams [] env = empty


type IlxOpFrag = IlxEnv -> SDoc
ilxOp :: String -> IlxOpFrag
ilxOp s env = text s
ilxOpSeq :: [IlxOpFrag] -> IlxOpFrag
ilxOpSeq ops env = hsep (map (\x -> x env) ops)

ilxParams :: [IlxOpFrag] -> IlxOpFrag
ilxParams l env = parens (ilxParamsAux l env)
  where
   ilxParamsAux [] env = empty
   ilxParamsAux [h] env = h env
   ilxParamsAux (h:t) env = h env <> text "," <+> ilxParamsAux t env


ilxMethodRef rty cls nm tyargs args = 
    ilxOpSeq [rty,cls,ilxOp "::",ilxOp nm,
              ilxTyParams tyargs,ilxParams args]

ilxCall m = ilxOpSeq [ilxOp "call", m]

ilxSupportClass = ilxOpSeq [prelGHCReference, ilxOp "'GHC.support'"]
ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args

ilxCallSuppMeth rty nm tyargs args  = ilxCall (ilxSuppMeth rty nm tyargs args)

ilxMkBool :: IlxOpFrag
ilxMkBool =  ilxOpSeq [ilxOp "call class",prelBaseReference,
                       ilxOp "PrelBase_Bool",
                       prelGHCReference,ilxOp "GHC.support::mkBool(bool)"]
ilxCgt = ilxOpSeq [ilxOp "cgt",ilxMkBool]
ilxCge = ilxOpSeq [ilxOp "clt ldc.i4 0 ceq ",ilxMkBool]
ilxClt = ilxOpSeq [ilxOp "clt ",ilxMkBool]
ilxCle = ilxOpSeq [ilxOp "cgt ldc.i4 0 ceq ",ilxMkBool]
ilxCeq = ilxOpSeq [ilxOp "ceq ",ilxMkBool]
ilxCne = ilxOpSeq [ilxOp "ceq ldc.i4 0 ceq " ,ilxMkBool]
ilxCgtUn = ilxOpSeq [ilxOp "cgt.un ",ilxMkBool]
ilxCgeUn  = ilxOpSeq [ilxOp "clt.un ldc.i4 0 ceq ",ilxMkBool]
ilxCltUn = ilxOpSeq [ilxOp "clt.un ",ilxMkBool]
ilxCleUn = ilxOpSeq [ilxOp "cgt.un ldc.i4 0 ceq ",ilxMkBool]

ilxAddrOfForeignOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"]
ilxAddrOfByteArrOp = ilxOp "ldc.i4 0 ldelema unsigned int8"

ilxPrimOpTable :: PrimOp -> [StgArg] -> IlxOpFrag
ilxPrimOpTable op
  = case op of
 	CharGtOp    -> simp_op ilxCgt
	CharGeOp    -> simp_op ilxCge
	CharEqOp    -> simp_op ilxCeq
	CharNeOp    -> simp_op ilxCne
	CharLtOp    -> simp_op ilxClt
	CharLeOp    -> simp_op ilxCle

	OrdOp       -> simp_op (ilxOp "conv.i4") -- chars represented by UInt32 (u4)
	ChrOp       -> simp_op (ilxOp "conv.u4")

	IntGtOp     -> simp_op ilxCgt
	IntGeOp     -> simp_op ilxCge
	IntEqOp     -> simp_op ilxCeq
	IntNeOp     -> simp_op ilxCne
	IntLtOp     -> simp_op ilxClt
	IntLeOp     -> simp_op ilxCle

        Narrow8IntOp   -> simp_op  (ilxOp"conv.i1")
        Narrow16IntOp  -> simp_op (ilxOp "conv.i2")
        Narrow32IntOp  -> simp_op (ilxOp "conv.i4")
        Narrow8WordOp  -> simp_op (ilxOp "conv.u1")
        Narrow16WordOp -> simp_op (ilxOp "conv.u2")
        Narrow32WordOp -> simp_op (ilxOp "conv.u4")

	WordGtOp     -> simp_op ilxCgtUn
	WordGeOp     -> simp_op ilxCgeUn
	WordEqOp     -> simp_op ilxCeq
	WordNeOp     -> simp_op ilxCne
	WordLtOp     -> simp_op ilxCltUn
	WordLeOp     -> simp_op ilxCleUn

	AddrGtOp     -> simp_op ilxCgt
	AddrGeOp     -> simp_op ilxCge
	AddrEqOp     -> simp_op ilxCeq
	AddrNeOp     -> simp_op ilxCne
	AddrLtOp     -> simp_op ilxClt
	AddrLeOp     -> simp_op ilxCle

	FloatGtOp     -> simp_op ilxCgt
	FloatGeOp     -> simp_op ilxCge
	FloatEqOp     -> simp_op ilxCeq
	FloatNeOp     -> simp_op ilxCne
	FloatLtOp     -> simp_op ilxClt
	FloatLeOp     -> simp_op ilxCle

	DoubleGtOp     -> simp_op ilxCgt
	DoubleGeOp     -> simp_op ilxCge
	DoubleEqOp     -> simp_op ilxCeq
	DoubleNeOp     -> simp_op ilxCne
	DoubleLtOp     -> simp_op ilxClt
	DoubleLeOp     -> simp_op ilxCle

    -- Int#-related ops:
	IntAddOp    -> simp_op (ilxOp "add")
	IntSubOp    -> simp_op (ilxOp "sub")
	IntMulOp    -> simp_op (ilxOp "mul")
	IntQuotOp   -> simp_op (ilxOp "div")
	IntNegOp    -> simp_op (ilxOp "neg")
	IntRemOp    -> simp_op (ilxOp "rem")

    -- Addr# ops:
        AddrAddOp  -> simp_op (ilxOp "add")
	AddrSubOp  -> simp_op (ilxOp "sub")
	AddrRemOp  -> simp_op (ilxOp "rem")
	Int2AddrOp -> warn_op "int2Addr" (simp_op (ilxOp "/* PrimOp int2Addr */ "))
	Addr2IntOp -> warn_op "addr2Int" (simp_op (ilxOp "/* PrimOp addr2Int */ "))

    -- Word#-related ops:
	WordAddOp    -> simp_op (ilxOp "add")
	WordSubOp    -> simp_op (ilxOp "sub")
	WordMulOp    -> simp_op (ilxOp "mul")
	WordQuotOp   -> simp_op (ilxOp "div")
	WordRemOp    -> simp_op (ilxOp "rem")

	ISllOp      -> simp_op (ilxOp "shl")
	ISraOp      -> simp_op (ilxOp "shr")
	ISrlOp      -> simp_op (ilxOp "shr.un")
	IntAddCOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt])
	IntSubCOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt])
	IntGcdOp    -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt])


    -- Word#-related ops:
	AndOp  	    -> simp_op (ilxOp "and") 
	OrOp   	    -> simp_op (ilxOp "or") 
	NotOp  	    -> simp_op (ilxOp "not") 
	XorOp  	    -> simp_op (ilxOp "xor") 
	SllOp  	    -> simp_op (ilxOp "shl") 
	SrlOp 	    -> simp_op (ilxOp "shr") 
	Word2IntOp  -> simp_op (ilxOp "conv.i4")
	Int2WordOp  -> simp_op (ilxOp "conv.u4")

    -- Float#-related ops:
	FloatAddOp   -> simp_op (ilxOp "add")
	FloatSubOp   -> simp_op (ilxOp "sub")
	FloatMulOp   -> simp_op (ilxOp "mul")
	FloatDivOp   -> simp_op (ilxOp "div")
	FloatNegOp   -> simp_op (ilxOp "neg")
	Float2IntOp  -> simp_op (ilxOp "conv.i4")
	Int2FloatOp  -> simp_op (ilxOp "conv.r4")

	DoubleAddOp   	-> simp_op (ilxOp "add")
	DoubleSubOp   	-> simp_op (ilxOp "sub")
	DoubleMulOp   	-> simp_op (ilxOp "mul")
	DoubleDivOp   	-> simp_op (ilxOp "div")
	DoubleNegOp   	-> simp_op (ilxOp "neg")
	Double2IntOp  	-> simp_op (ilxOp "conv.i4")
	Int2DoubleOp  	-> simp_op (ilxOp "conv.r4")
	Double2FloatOp  -> simp_op (ilxOp "conv.r4")
	Float2DoubleOp  -> simp_op (ilxOp "conv.r8")
	DoubleDecodeOp  -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [ilxType "float64"])
	FloatDecodeOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [ilxType "float32"])

	FloatExpOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4")
	FloatLogOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4")
	FloatSqrtOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4")
	FloatSinOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4")
	FloatCosOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4")
	FloatTanOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4")
	FloatAsinOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4")
	FloatAcosOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4")
	FloatAtanOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4")
	FloatSinhOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")
	FloatCoshOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")
	FloatTanhOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")
	FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8...

	DoubleExpOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)")
	DoubleLogOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)")
	DoubleSqrtOp  -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sqrt(float64)")
          
	DoubleSinOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sin(float64)")
	DoubleCosOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cos(float64)")
	DoubleTanOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tan(float64)")
          
	DoubleAsinOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Asin(float64)")
	DoubleAcosOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Acos(float64)")
	DoubleAtanOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Atan(float64)")
          
	DoubleSinhOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sinh(float64)")
	DoubleCoshOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cosh(float64)")
	DoubleTanhOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tanh(float64)")
          
	DoublePowerOp  -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64)")

    -- Integer (and related...) ops: bail out to support routines
	IntegerAndOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerAndOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerOrOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerOrOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerXorOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerXorOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerComplementOp -> simp_op (ilxCallSuppMeth repInteger "IntegerComplementOp" [] [repInt, repByteArray])
	IntegerAddOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerSubOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerMulOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerGcdOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerQuotRemOp   -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerDivModOp    -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerIntGcdOp    -> simp_op (ilxCallSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt])
	IntegerDivExactOp  -> simp_op (ilxCallSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerQuotOp  	   -> simp_op (ilxCallSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerRemOp   	   -> simp_op (ilxCallSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerCmpOp   	   -> simp_op (ilxCallSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray])
	IntegerCmpIntOp    -> simp_op (ilxCallSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt])
	Integer2IntOp      -> simp_op (ilxCallSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray])
	Integer2WordOp     -> simp_op (ilxCallSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray])
	Int2IntegerOp  	   -> simp_op (ilxCallSuppMeth repInteger "Int2IntegerOp" [] [repInt])
	Word2IntegerOp     -> simp_op (ilxCallSuppMeth repInteger "Word2IntegerOp" [] [repWord])
--	IntegerToInt64Op   -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray])
	Int64ToIntegerOp   -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64])
--	IntegerToWord64Op  -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])
	Word64ToIntegerOp  -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64])



	IndexByteArrayOp_Char  	   -> simp_op (ilxOp "ldelem.u1")
	IndexByteArrayOp_WideChar  -> simp_op (ilxOp "ldelem.u4")
	IndexByteArrayOp_Int   	   -> simp_op (ilxOp "ldelem.i4")
	IndexByteArrayOp_Word  	   -> simp_op (ilxOp "ldelem.u4")
	IndexByteArrayOp_Addr  	   -> simp_op (ilxOp "ldelem.u")
	IndexByteArrayOp_Float 	   -> simp_op (ilxOp "ldelem.r4")
	IndexByteArrayOp_Double    -> simp_op (ilxOp "ldelem.r8")
	IndexByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref")
	IndexByteArrayOp_Int8     -> simp_op (ilxOp "ldelem.i1")
	IndexByteArrayOp_Int16     -> simp_op (ilxOp "ldelem.i2")
	IndexByteArrayOp_Int32     -> simp_op (ilxOp "ldelem.i4")
	IndexByteArrayOp_Int64     -> simp_op (ilxOp "ldelem.i8")
	IndexByteArrayOp_Word8    -> simp_op (ilxOp "ldelem.u1")
	IndexByteArrayOp_Word16    -> simp_op (ilxOp "ldelem.u2")
	IndexByteArrayOp_Word32    -> simp_op (ilxOp "ldelem.u4")
	IndexByteArrayOp_Word64    -> simp_op (ilxOp "ldelem.u8")

            {- should be monadic??? -}
	ReadByteArrayOp_Char   	  -> simp_op (ilxOp "ldelem.u1")
	ReadByteArrayOp_WideChar  -> simp_op (ilxOp "ldelem.u4")
	ReadByteArrayOp_Int    	  -> simp_op (ilxOp "ldelem.i4")
	ReadByteArrayOp_Word   	  -> simp_op (ilxOp "ldelem.u4")
	ReadByteArrayOp_Addr   	  -> simp_op (ilxOp "ldelem.u")
	ReadByteArrayOp_Float  	  -> simp_op (ilxOp "ldelem.r4")
	ReadByteArrayOp_Double 	  -> simp_op (ilxOp "ldelem.r8")
	ReadByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref")
	ReadByteArrayOp_Int8     -> simp_op (ilxOp "ldelem.i1")
	ReadByteArrayOp_Int16     -> simp_op (ilxOp "ldelem.i2")
	ReadByteArrayOp_Int32     -> simp_op (ilxOp "ldelem.i4")
	ReadByteArrayOp_Int64     -> simp_op (ilxOp "ldelem.i8")
	ReadByteArrayOp_Word8    -> simp_op (ilxOp "ldelem.u1")
	ReadByteArrayOp_Word16    -> simp_op (ilxOp "ldelem.u2")
	ReadByteArrayOp_Word32    -> simp_op (ilxOp "ldelem.u4")
	ReadByteArrayOp_Word64    -> simp_op (ilxOp "ldelem.u8")
                 {-   MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -}
                 {- ByteArr# -> Int# -> Char# -}


	WriteByteArrayOp_Char  	   -> simp_op (ilxOp "stelem.u1")
	WriteByteArrayOp_WideChar   -> simp_op (ilxOp "stelem.u4")
	WriteByteArrayOp_Int   	   -> simp_op (ilxOp "stelem.i4")
	WriteByteArrayOp_Word  	   -> simp_op (ilxOp "stelem.u4")
	WriteByteArrayOp_Addr  	   -> simp_op (ilxOp "stelem.u")
	WriteByteArrayOp_Float 	   -> simp_op (ilxOp "stelem.r4")
	WriteByteArrayOp_Double    -> simp_op (ilxOp "stelem.r8")
	WriteByteArrayOp_StablePtr -> simp_op (ilxOp "stelem.ref")
	WriteByteArrayOp_Int8     -> simp_op (ilxOp "stelem.i1")
	WriteByteArrayOp_Int16     -> simp_op (ilxOp "stelem.i2")
	WriteByteArrayOp_Int32     -> simp_op (ilxOp "stelem.i4")
	WriteByteArrayOp_Int64     -> simp_op (ilxOp "stelem.i8")
	WriteByteArrayOp_Word8    -> simp_op (ilxOp "stelem.u1")
	WriteByteArrayOp_Word16    -> simp_op (ilxOp "stelem.u2")
	WriteByteArrayOp_Word32    -> simp_op (ilxOp "stelem.u4")
	WriteByteArrayOp_Word64    -> simp_op (ilxOp "stelem.i8 /* nb. no stelem.u8 */")
                 {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -}

	IndexOffAddrOp_Char    -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
	IndexOffAddrOp_WideChar    -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
	IndexOffAddrOp_Int     -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
	IndexOffAddrOp_Word    -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
	IndexOffAddrOp_Addr    -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i")
	IndexOffAddrOp_StablePtr   -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref")
	IndexOffAddrOp_Float   -> simp_op (ilxOp "sizeof float32 mul add ldind.r4")
	IndexOffAddrOp_Double  -> simp_op (ilxOp "sizeof float64 mul add ldind.r8")
	IndexOffAddrOp_Int8   -> simp_op (ilxOp "sizeof int8 mul add ldind.i1")
	IndexOffAddrOp_Int16   -> simp_op (ilxOp "sizeof int16 mul add ldind.i2")
	IndexOffAddrOp_Int32   -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
	IndexOffAddrOp_Int64   -> simp_op (ilxOp "sizeof int64 mul add ldind.i8")
	IndexOffAddrOp_Word8  -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
	IndexOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2")
	IndexOffAddrOp_Word32  -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
	IndexOffAddrOp_Word64  -> simp_op (ilxOp "sizeof int64 mul add ldind.u8")

	-- ForeignObj: load the address inside the object first
        -- TODO: is this remotely right?
	EqForeignObj                 -> warn_op "eqForeignObj" (simp_op (ilxOp "pop /* PrimOp eqForeignObj */ "))
        IndexOffForeignObjOp_Char    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
	IndexOffForeignObjOp_WideChar    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.u4"])
	IndexOffForeignObjOp_Int     -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
	IndexOffForeignObjOp_Word    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
	IndexOffForeignObjOp_Addr    ->  arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.i  "])
	IndexOffForeignObjOp_StablePtr    ->  ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref  "])
	IndexOffForeignObjOp_Float   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float32 mul add ldind.r4"])
	IndexOffForeignObjOp_Double  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float64 mul add ldind.r8"])
	IndexOffForeignObjOp_Int8   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int8 mul add ldind.i1"])
	IndexOffForeignObjOp_Int16   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int16 mul add ldind.i2"])
	IndexOffForeignObjOp_Int32   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
	IndexOffForeignObjOp_Int64   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int64 mul add ldind.i8"])
	IndexOffForeignObjOp_Word8  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
	IndexOffForeignObjOp_Word16  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"])
	IndexOffForeignObjOp_Word32  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
	IndexOffForeignObjOp_Word64  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"])

	ReadOffAddrOp_Char   -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
	ReadOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
	ReadOffAddrOp_Int    -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
	ReadOffAddrOp_Word   -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
	ReadOffAddrOp_Addr   -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i")
	ReadOffAddrOp_Float  -> simp_op (ilxOp "sizeof float32 mul add ldind.r4")
	ReadOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8")
	ReadOffAddrOp_StablePtr  -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref")
	ReadOffAddrOp_Int8  -> simp_op (ilxOp "sizeof int8 mul add ldind.i1")
	ReadOffAddrOp_Int16  -> simp_op (ilxOp "sizeof int16 mul add ldind.i2")
	ReadOffAddrOp_Int32  -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
	ReadOffAddrOp_Int64  -> simp_op (ilxOp "sizeof int64 mul add ldind.i8")
	ReadOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
	ReadOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2")
	ReadOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
	ReadOffAddrOp_Word64 -> simp_op (ilxOp "sizeof unsigned int64 mul add ldind.u8")
                  {-    Addr# -> Int# -> Char# -> State# s -> State# s -} 

	WriteOffAddrOp_Char   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "add", v, ilxOp "stind.u1"])
	WriteOffAddrOp_WideChar   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"])
	WriteOffAddrOp_Int    -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.i4"])
	WriteOffAddrOp_Word   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"])
	WriteOffAddrOp_Addr   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.i"])
	WriteOffAddrOp_ForeignObj   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"])
	WriteOffAddrOp_Float  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof float32 mul add", v,ilxOp "stind.r4"])
	WriteOffAddrOp_StablePtr   -> ty2_arg4_op (\ty1 sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"])
	WriteOffAddrOp_Double -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof float64 mul add",v,ilxOp "stind.r8"])
	WriteOffAddrOp_Int8  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int8 mul add",v,ilxOp "stind.i1"])
	WriteOffAddrOp_Int16  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int16 mul add",v,ilxOp "stind.i2"])
	WriteOffAddrOp_Int32  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int32 mul add",v,ilxOp "stind.i4"])
	WriteOffAddrOp_Int64  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int64 mul add",v,ilxOp "stind.i8"])
	WriteOffAddrOp_Word8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int8 mul add",v,ilxOp "stind.u1"])
	WriteOffAddrOp_Word16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int16 mul add",v,ilxOp "stind.u2"])
	WriteOffAddrOp_Word32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int32 mul add",v,ilxOp "stind.u4"])
	WriteOffAddrOp_Word64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int64 mul add",v,ilxOp "stind.u8"])
                  {-    Addr# -> Int# -> Char# -> State# s -> State# s -} 

            {- should be monadic??? -}
	NewPinnedByteArrayOp_Char -> warn_op "newPinnedByteArray" (simp_op (ilxOp "newarr [mscorlib]System.Byte "))
	NewByteArrayOp_Char   	 -> simp_op (ilxOp "newarr [mscorlib]System.Byte")
--	NewByteArrayOp_Int    	 -> simp_op (ilxOp "newarr [mscorlib]System.Int32")
--	NewByteArrayOp_Word   	 -> simp_op (ilxOp "newarr [mscorlib]System.UInt32")
--	NewByteArrayOp_Addr   	 -> simp_op (ilxOp "newarr [mscorlib]System.UInt64")
--	NewByteArrayOp_Float  	 -> simp_op (ilxOp "newarr [mscorlib]System.Single")
--	NewByteArrayOp_Double 	 -> simp_op (ilxOp "newarr [mscorlib]System.Double")
--	NewByteArrayOp_StablePtr -> simp_op (ilxOp "newarr [mscorlib]System.UInt32")
--      NewByteArrayOp_Int64     -> simp_op (ilxOp "newarr [mscorlib]System.Int64")  TODO: there is no unique for this one -}
--      NewByteArrayOp_Word64    -> simp_op (ilxOp "newarr  [mscorlib]System.UInt64") -}
                  {- Int# -> State# s -> (# State# s, MutByteArr# s #) -}
	ByteArrayContents_Char   -> warn_op "byteArrayContents" (simp_op ilxAddrOfByteArrOp)

	UnsafeFreezeByteArrayOp ->   ty1_op (\ty1  -> ilxOp "nop ")
                  {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -}
	SizeofByteArrayOp  -> simp_op (ilxOp "ldlen")
                  {- ByteArr# -> Int# -}

	SameMutableByteArrayOp -> ty1_op (\ty1  -> ilxCeq)
                 {- MutByteArr# s -> MutByteArr# s -> Bool -}
	SizeofMutableByteArrayOp -> ty1_op (\ty1  -> ilxOp "ldlen")
                 {- MutByteArr# s -> Int# -}

	SameMutVarOp -> ty2_op (\ty1 ty2 -> ilxCeq)
                 {- MutVar# s a -> MutVar# s a -> Bool -}
	NewMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "newobj void" , repMutVar ty1 ty2 , ilxOp "::.ctor(!0)"])
                 {- a -> State# s -> (# State# s, MutVar# s a #) -}
	ReadMutVarOp -> ty2_op (\ty1 ty2 ->  ilxOpSeq [ilxOp "ldfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"])
                 {-  MutVar# s a -> State# s -> (# State# s, a #) -}
	WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"])
                 {- MutVar# s a -> a -> State# s -> State# s -}

	NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA])
                 {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -}
	IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref")
                 {- Array# a -> Int# -> (# a #) -}
	WriteArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "stelem.ref")
                 {- MutArr# s a -> Int# -> a -> State# s -> State# s -}
	ReadArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "ldelem.ref")
                 {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -}
	UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop")
                 {-   MutArr# s a -> State# s -> (# State# s, Array# a #) -}
	UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop")
                 {-  Array# a -> State# s -> (# State# s, MutArr# s a #) -}

	SameMutableArrayOp -> ty2_op (\ty1 ty2 -> ilxCeq)
                 {- MutArr# s a -> MutArr# s a -> Bool -}


	RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw")
	CatchOp -> ty2_op (\ty1 ty2 -> 
		ilxCallSuppMeth ilxMethTyVarA "'catch'" [ty1,ty2] [ilxLift (ilxTyIO (ilxType "!!0")), 
                                                              ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"])
	                    {-        (State# RealWorld -> (# State# RealWorld, a #) )
	                           -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) 
	                           -> State# RealWorld
	                           -> (# State# RealWorld, a #) 
	                     -} 

	BlockAsyncExceptionsOp -> ty1_op (\ty1 -> 
		ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])

                {-     (State# RealWorld -> (# State# RealWorld, a #))
                    -> (State# RealWorld -> (# State# RealWorld, a #))
                -}

	UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> 
		ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])

                {-
		    State# RealWorld -> (# State# RealWorld, a #))
                    -> (State# RealWorld -> (# State# RealWorld, a #))
                -}
 
	NewMVarOp -> ty2_op (\sty ty -> 
		ilxOpSeq [ilxOp "newobj void " , repMVar ty , ilxOp "::.ctor()"])
                 {- State# s -> (# State# s, MVar# s a #) -}

	TakeMVarOp -> ty2_op (\sty ty -> 
		ilxCallSuppMeth ilxMethTyVarA "takeMVar" [ty] [repMVar ilxMethTyVarA])
                  {-  MVar# s a -> State# s -> (# State# s, a #) -}

	-- These aren't yet right
        TryTakeMVarOp -> ty2_op (\sty ty -> 
		ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])
                  {-  MVar# s a -> State# s -> (# State# s, a #) -}

	TryPutMVarOp -> ty2_op (\sty ty -> 
		ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA])
                  {-  MVar# s a -> State# s -> (# State# s, a #) -}

	PutMVarOp -> ty2_op (\sty ty -> 
		ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA])
                   {- MVar# s a -> a -> State# s -> State# s -}

	SameMVarOp -> ty2_op (\sty ty -> ilxCeq)
                   {- MVar# s a -> MVar# s a -> Bool -}

--	TakeMaybeMVarOp -> ty2_op (\sty ty -> 
--		(ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]))
--              {- MVar# s a -> State# s -> (# State# s, Int#, a #) -}

	IsEmptyMVarOp -> ty2_op (\sty ty -> 
		ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA])
               {- MVar# s a -> State# s -> (# State# s, Int# #) -}

	TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ "))

               {- a -> Int# -}
	DataToTagOp -> ty1_op (\ty1 -> 
		ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA])
               {- a -> Int# -}

	TagToEnumOp -> ty1_op (\ty1 -> 
		ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt])
               {- Int# -> a -}

	MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"])
                 {-   a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -}
	MakeStableNameOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "pop newobj void", repStableName {- ty1 -}, ilxOp "::.ctor()"])
                        -- primOpInfo MakeStableNameOp = mkGenPrimOp SLIT("makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))

        EqStableNameOp -> ty1_op (\ty1 -> ilxOp "ceq")
               -- [alphaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy alphaTy] (intPrimTy)
        StableNameToIntOp -> warn_op "StableNameToIntOp" (ty1_op (\ty1 -> ilxOp "pop ldc.i4 0"))
               -- [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)

	DeRefStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "ldfld class [mscorlib]System.Object", repStablePtr {- ty1 -}, ilxOp "::contents"])
                 {-  StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -}

	EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq")
                 {-  StablePtr# a -> StablePtr# a -> Int# -}

            -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> ()
	MkWeakOp -> ty3_op (\ty1 ty2 ty3 ->  ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)]))
                 {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -}

	DeRefWeakOp -> ty1_op (\ty1 ->  ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethTyVarA) classWeak "deref" [ty1] [repWeak ilxMethTyVarA]))
	FinalizeWeakOp -> ty1_op (\ty1 ->  ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxTyIO ilxUnboxedEmptyRep)) classWeak "finalizer" [ty1] [repWeak ilxMethTyVarA]))
                   {-    Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, 
	State# RealWorld -> (# State# RealWorld, Unit #)) #) -}

	MkForeignObjOp -> simp_op (ilxOpSeq [ilxOp "newobj void", repForeign, ilxOp "::.ctor(void *)"])
	WriteForeignObjOp -> ty1_op (\sty -> ilxOpSeq [ilxOp "stfld void *", repForeign, ilxOp "::contents"])
        ForeignObjToAddrOp -> simp_op ilxAddrOfForeignOp
	YieldOp -> simp_op (ilxOpSeq [ilxOp "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() 
                                call instance void class [mscorlib]System.Threading.Thread::Suspend()"])
	MyThreadIdOp -> simp_op (ilxOpSeq [ilxOp "call default  class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() "])
	-- This pushes a THUNK across as the exception value.
        -- This is the correct Haskell semantics...  TODO: we should probably
        -- push across an HaskellThreadAbortException object that wraps this
        -- thunk, but which is still actually an exception of
        -- an appropriate type.
        KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "])
              {-   ThreadId# -> a -> State# RealWorld -> State# RealWorld -}

	ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParOp ->  warn_op "ParOp" (simp_op (ilxOp "/* ParOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	DelayOp -> simp_op (ilxOp "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ")
                 {-    Int# -> State# s -> State# s -}

	WaitReadOp  -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop"))
   	WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParAtOp -> warn_op "ParAtOp" (simp_op (ilxOp " /* ParAtOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParLocalOp -> warn_op "ParLocalOp" (simp_op (ilxOp " /* ParLocalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	ParGlobalOp -> warn_op "ParGlobalOp" (simp_op (ilxOp " /* ParGlobalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
	SeqOp -> warn_op "SeqOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw "))
	AddrToHValueOp -> warn_op "AddrToHValueOp" (simp_op (ilxOp "newobj void [mscorlib]System.Object::.ctor() throw"))
--	ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq")

        MkApUpd0_Op ->  warn_op "MkApUpd0_Op" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
        NewBCOOp ->  warn_op "NewBCOOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
                  -- ("newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy deltaTy, bcoPrimTy]))
        _        -> pprPanic "Unimplemented primop" (ppr op)


ty1_op :: (IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty1_op  op ((StgTypeArg ty1):rest)  = 
      ilxOpSeq [getArgsStartingAt 1 rest, 
                op (ilxTypeR2 (deepIlxRepType ty1))]

ty2_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty2_op  op ((StgTypeArg ty1):(StgTypeArg ty2):rest)  = 
      ilxOpSeq [getArgsStartingAt 2 rest, 
                op (ilxTypeR2 (deepIlxRepType ty1)) 
                   (ilxTypeR2 (deepIlxRepType ty2))]

ty3_op :: (IlxTyFrag -> IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty3_op  op ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = 
      ilxOpSeq [getArgsStartingAt 3 rest, 
                op (ilxTypeR2 (deepIlxRepType ty1)) 
                   (ilxTypeR2 (deepIlxRepType ty2))
                   (ilxTypeR2 (deepIlxRepType ty3))]

arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
arg2_op  op [a1, a2] = 
       op (getAsArg 1 a1)
          (getAsArg 2 a2)

ty1_arg2_op :: (IlxTyFrag -> IlxOpFrag ->  IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty1_arg2_op  op [(StgTypeArg ty1), a1, a2] = 
       op (ilxTypeR2 (deepIlxRepType ty1)) 
          (getAsArg 1 a1)
          (getAsArg 2 a2)

ty1_arg4_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty1_arg4_op  op [(StgTypeArg ty1), a1, a2, a3, a4] = 
       op (ilxTypeR2 (deepIlxRepType ty1)) 
          (getAsArg 1 a1)
          (getAsArg 2 a2)
          (getAsArg 3 a3)
          (getAsArg 4 a4)

ty2_arg4_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
ty2_arg4_op  op [(StgTypeArg ty1), (StgTypeArg ty2),a1, a2, a3, a4] = 
       op (ilxTypeR2 (deepIlxRepType ty1)) 
          (ilxTypeR2 (deepIlxRepType ty2)) 
          (getAsArg 2 a1)
          (getAsArg 3 a2)
          (getAsArg 4 a3)
          (getAsArg 5 a4)

hd (h:t) = h

getAsArg n a env = hd (ilxMapPlaceArgs n pushArg env [a])
getArgsStartingAt n a env = vcat (ilxMapPlaceArgs n pushArg env a)

simp_op :: IlxOpFrag -> [StgArg] -> IlxOpFrag
simp_op  op args env    = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op env
warn_op  warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args)
\end{code}

%************************************************************************
%*									*
\subsection{C Calls}
%*									*
%************************************************************************

\begin{code}
-- Call the P/Invoke stub wrapper generated in the import section.
-- We eliminate voids in and around an IL C Call.  
-- We also do some type-directed translation for pinning Haskell-managed blobs
-- of data as we throw them across the boundary.
ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty
 = ilxComment ((text "C call") <+> pprCLabelString c) <+> 
	vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
              text "call" <+> retdoc <+> pprCLabelString c <+> tyarg_doc
                    <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
  where 
    retdoc | isVoidIlxRepType ret_ty = text "void"
	   | otherwise		     = ilxTypeR env (deepIlxRepType ret_ty)
    (ty_args,tm_args) = splitTyArgs1 args
    tyarg_doc | not (isEmptyVarSet (tyVarsOfTypes ty_args)) = text "/* type variable found */"
	      | otherwise = pprTypeArgs ilxTypeR env ty_args

ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty
  = ilxComment (text "IL call") <+> 
    vcat [vcat (ilxMapPlaceArgs 0 pushEvalArg env tm_args), 
	  ptext call_instr
		-- In due course we'll need to pass the type arguments
		-- and to do that we'll need to have more than just a string
		-- for call_instr
    ]
  where
    (ty_args,tm_args) = splitTyArgs1 args 

-- Push and argument and force its evaluation if necessary.
pushEvalArg _ (StgTypeArg _) = empty
pushEvalArg env (StgVarArg arg) = ilxFunApp env arg [] False
pushEvalArg env (StgLitArg lit) = pushLit env lit


hasTyCon (TyConApp tc _) tc2 = tc == tc2
hasTyCon _  _ = False

isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon
isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v))

isForeignObjCArgTy ty = hasTyCon ty foreignObjPrimTyCon
isForeignObjCArg v = isForeignObjCArgTy (deepIlxRepType (idType v))

pinCCallArg v = isByteArrayCArg v || isForeignObjCArg v  

pinCArg  env arg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") 
pushCArg  env arg@(StgVarArg v) | isByteArrayCArg v = pinCArg env arg v <+> ilxAddrOfByteArrOp env
pushCArg env arg@(StgVarArg v) | isForeignObjCArg v = pinCArg env arg v <+> ilxAddrOfForeignOp env
pushCArg env arg | otherwise = pushArg env arg

pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys)
pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#")
pprCValArgTy f env ty | isForeignObjCArgTy ty = text "void *" <+> ilxComment (text "foreign object")
pprCValArgTy f env ty | otherwise = f env ty


foldR            :: (a -> b -> b) -> [a] -> b -> b
-- foldR _ [] z     =  z
-- foldR f (x:xs) z =  f x (foldR f xs z) 
{-# INLINE foldR #-}
foldR k xs z = go xs
	     where
	       go []     = z
	       go (y:ys) = y `k` go ys

\end{code}