module IRTS.CodegenC (codegenC) where import Idris.AbsSyntax import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified import IRTS.CodegenCommon import Core.TT import Paths_idris import Util.System import Data.Char import Data.List (intercalate) import System.Process import System.Exit import System.IO import System.Directory import System.FilePath ((), (<.>)) import Control.Monad codegenC :: [(Name, SDecl)] -> String -> -- output file name OutputType -> -- generate executable if True, only .o if False [FilePath] -> -- include files String -> -- extra object files String -> -- extra compiler flags DbgLevel -> IO () codegenC defs out exec incs objs libs dbg = do -- print defs let bc = map toBC defs let h = concatMap toDecl (map fst bc) let cc = concatMap (uncurry toC) bc d <- getDataDir mprog <- readFile (d "rts" "idris_main" <.> "c") let cout = headers incs ++ debug dbg ++ h ++ cc ++ (if (exec == Executable) then mprog else "") case exec of Raw -> writeFile out cout _ -> do (tmpn, tmph) <- tempfile hPutStr tmph cout hFlush tmph hClose tmph let useclang = False comp <- getCC libFlags <- getLibFlags incFlags <- getIncFlags let gcc = comp ++ " " ++ gccDbg dbg ++ " -I. " ++ objs ++ " -x c " ++ (if (exec == Executable) then "" else " -c ") ++ " " ++ tmpn ++ " " ++ libFlags ++ " " ++ incFlags ++ " " ++ libs ++ " -o " ++ out -- putStrLn gcc exit <- system gcc when (exit /= ExitSuccess) $ putStrLn ("FAILURE: " ++ gcc) headers xs = concatMap (\h -> "#include <" ++ h ++ ">\n") (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "gmp.h", "assert.h"]) debug TRACE = "#define IDRIS_TRACE\n\n" debug _ = "" gccDbg DEBUG = "-g" gccDbg TRACE = "-O2" gccDbg _ = "-O2" cname :: Name -> String cname n = "_idris_" ++ concatMap cchar (show n) where cchar x | isAlpha x || isDigit x = [x] | otherwise = "_" ++ show (fromEnum x) ++ "_" indent :: Int -> String indent n = replicate (n*4) ' ' creg RVal = "RVAL" creg (L i) = "LOC(" ++ show i ++ ")" creg (T i) = "TOP(" ++ show i ++ ")" creg Tmp = "REG1" toDecl :: Name -> String toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n" toC :: Name -> [BC] -> String toC f code = -- "/* " ++ show code ++ "*/\n\n" ++ "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++ indent 1 ++ "INITFRAME;\n" ++ concatMap (bcc 1) code ++ "}\n\n" bcc :: Int -> BC -> String bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (ASSIGNCONST l c) = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n" where mkConst (I i) = "MKINT(" ++ show i ++ ")" mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")" | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")" mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")" mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")" mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")" mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")" mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")" mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")" mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")" mkConst _ = "MKINT(42424242)" bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (MKCON l tag args) = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++ show (length args) ++ ", 0);\n" ++ indent i ++ setArgs 0 args ++ "\n" ++ indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n" -- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++ -- show (length args) ++ concatMap showArg args ++ ");\n" where showArg r = ", " ++ creg r setArgs i [] = "" setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++ "); " ++ setArgs (i + 1) xs bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++ ", " ++ show a ++ ");\n" bcc i (PROJECTINTO r t idx) = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n" bcc i (CASE True r code def) | length code < 4 = showCase i def code where showCode :: Int -> [BC] -> String showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++ indent i ++ "}\n" showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String showCase i Nothing [(t, c)] = showCode i c showCase i (Just def) [] = showCode i def showCase i def ((t, c) : cs) = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c ++ "else " ++ showCase i def cs bcc i (CASE safe r code def) = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++ concatMap (showCase i) code ++ showDef i def ++ indent i ++ "}\n" where ctag True = "CTAG" ctag False = "TAG" showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" showDef i Nothing = "" showDef i (Just c) = indent i ++ "default:\n" ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n" bcc i (CONSTCASE r code def) | intConsts code -- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++ -- concatMap (showCase i) code ++ -- showDef i def ++ -- indent i ++ "}\n" = concatMap (iCase (creg r)) code ++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n" | strConsts code = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n" | bigintConsts code = concatMap (biCase (creg r)) code ++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n" | otherwise = error $ "Can't happen: Can't compile const case " ++ show code where intConsts ((I _, _ ) : _) = True intConsts ((Ch _, _ ) : _) = True intConsts _ = False bigintConsts ((BI _, _ ) : _) = True bigintConsts _ = False strConsts ((Str _, _ ) : _) = True strConsts _ = False strCase sv (s, bc) = indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" biCase bv (BI b, bc) = indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" iCase v (I b, bc) = indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" iCase v (Ch b, bc) = indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" showDef i Nothing = "" showDef i (Just c) = indent i ++ "default:\n" ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n" showDefS i Nothing = "" showDefS i (Just c) = concatMap (bcc (i+1)) c bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n" bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n" bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n" bcc i REBASE = indent i ++ "REBASE;\n" bcc i (RESERVE 0) = "" bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n" bcc i (ADDTOP 0) = "" bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n" bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n" bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n" bcc i STOREOLD = indent i ++ "STOREOLD;\n" bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n" bcc i (FOREIGNCALL l LANG_C rty fn args) = indent i ++ c_irts rty (creg l ++ " = ") (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n" where fcall (t, arg) = irts_c t (creg arg) bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);" -- bcc i _ = indent i ++ "// not done yet\n" c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))" c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")" c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))" c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")" c_irts FUnit l x = x c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")" c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" c_irts FAny l x = l ++ x irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")" irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")" irts_c FChar x = "GETINT(" ++ x ++ ")" irts_c FString x = "GETSTR(" ++ x ++ ")" irts_c FUnit x = x irts_c FPtr x = "GETPTR(" ++ x ++ ")" irts_c FDouble x = "GETFLOAT(" ++ x ++ ")" irts_c FAny x = x bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")" bitCoerce v op input output arg = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")" signedTy :: IntTy -> String signedTy t = "int" ++ show (intTyWidth t) ++ "_t" doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")" doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")" doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")" doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")" doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")" doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")" doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")" doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")" doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")" doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")" doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))" doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))" doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)" doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y] doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y] doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y] doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y] doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y] doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y] doOp v (LLSHR ty) [x, y] = bitOp v "Shr" ty [x, y] doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y] doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y] doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y] doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y] doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x] doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y] doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y] doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y] doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y] doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y] doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y] doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y] doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))" doOp v (LSExt from to) [x] | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")" doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" doOp v (LZExt from to) [x] | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, mpz_get_ui(GETMPZ(" ++ creg x ++ "))" doOp v (LTrunc from to) [x] | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))" doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))" doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))" doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))" doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))" doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))" doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))" doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))" doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))" doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))" doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))" doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")" doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")" doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)" doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)" doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)" doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)" doOp v (LChInt ITNative) args = v ++ creg (last args) doOp v (LIntCh ITNative) args = v ++ creg (last args) doOp v LNoOp args = v ++ creg (last args) doOp _ op _ = "FAIL /* " ++ show op ++ " */"