3812df8 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Compile foreign calls

3812df8Edwin Brady14 years ago

iif/testvm.iif+5−1

compare with master

unifiedsplit

@@ -23,6 +23,10 @@ fun intToNat(x) = case x of {

23 | _ => S (intToNat (x - 1))

24 }

26+fun sin(x) = foreign C Float "sin" (Float x)

27+

26fun main() = let val = natToInt(plus(intToNat(fact(6)), S(S(O)))) in

28fun main() = let val = natToInt(plus(intToNat(fact(6)), S(S(O)))) in

29+ let sval = sin(1.0) in

27− %WriteString("Answer: " ++ %IntString(val))

30+ %WriteString("Answer: " ++ %IntString(val)

31+ ++ " " ++ %FloatString(sval))

src/IRTS/CodegenC.hs+5−3

@@ -26,7 +26,8 @@ codegenC :: [(Name, LDecl)] ->

26 DbgLevel ->

27 IO ()

28codegenC defs out exec incs libs dbg

29+ = do -- print defs

29− = do let tagged = addTags defs

30+ let tagged = addTags defs

30 let ctxtIn = addAlist tagged emptyContext

31 let ctxtIn = addAlist tagged emptyContext

31 let checked = checkDefs ctxtIn tagged

32 let checked = checkDefs ctxtIn tagged

32 case checked of

33 case checked of

@@ -47,6 +48,7 @@ codegenC defs out exec incs libs dbg

47 " " ++ tmpn ++

48 " " ++ tmpn ++

48 " `idris --link` `idris --include` " ++ libs ++

49 " `idris --link` `idris --include` " ++ libs ++

49 " -lidris_rts -o " ++ out

50 " -lidris_rts -o " ++ out

51+-- putStrLn cout

50 exit <- system gcc

52 exit <- system gcc

51 when (exit /= ExitSuccess) $

53 when (exit /= ExitSuccess) $

52 putStrLn ("FAILURE: " ++ gcc)

54 putStrLn ("FAILURE: " ++ gcc)

@@ -56,7 +58,7 @@ codegenC defs out exec incs libs dbg

56headers [] = "#include <idris_rts.h>\n\n"

58headers [] = "#include <idris_rts.h>\n\n"

57headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs

59headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs

59−debug DEBUG = "#define IDRIS_DEBUG\n\n"

61+debug TRACE = "#define IDRIS_DEBUG\n\n"

60debug _ = ""

62debug _ = ""

62gccDbg DEBUG = "-g"

64gccDbg DEBUG = "-g"

@@ -136,7 +138,7 @@ bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"

136bcc i (FOREIGNCALL l LANG_C rty fn args)

138bcc i (FOREIGNCALL l LANG_C rty fn args)

137 = indent i ++ creg l ++ " = " ++

139 = indent i ++ creg l ++ " = " ++

138 c_irts rty (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

140 c_irts rty (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

139− where fcall (t, arg) = irts_c t (creg l)

141+ where fcall (t, arg) = irts_c t (creg arg)

140-- bcc i _ = indent i ++ "// not done yet\n"

142-- bcc i _ = indent i ++ "// not done yet\n"

141

143

142c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"

144c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"

src/IRTS/LParser.hs+29−12

@@ -46,7 +46,7 @@ lchar = lexeme.char

47fovm :: FilePath -> IO ()

48fovm f = do defs <- parseFOVM f

49− codegenC defs "a.out" True [] "" DEBUG

49+ codegenC defs "a.out" True ["math.h"] "" TRACE

51parseFOVM :: FilePath -> IO [(Name, LDecl)]

52parseFOVM fname = do -- putStrLn $ "Reading " ++ fname

@@ -144,20 +144,37 @@ pCase = do reserved "case"; e <- pLExp; reserved "of"

144 return (LCase e alts)

145

146pCast :: LParser LExp

147−pCast = do reserved "FloatString"; e <- pLExp; return (LOp LFloatStr [e])

147+pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'

148+ return (LOp LFloatStr [e])

148− <|> do reserved "StringFloat"; e <- pLExp; return (LOp LStrFloat [e])

149+ <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'

150+ return (LOp LStrFloat [e])

149− <|> do reserved "FloatInt"; e <- pLExp; return (LOp LFloatInt [e])

151+ <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'

152+ return (LOp LFloatInt [e])

150− <|> do reserved "IntFloat"; e <- pLExp; return (LOp LIntFloat [e])

153+ <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'

154+ return (LOp LIntFloat [e])

151− <|> do reserved "StringInt"; e <- pLExp; return (LOp LStrInt [e])

155+ <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'

156+ return (LOp LStrInt [e])

152− <|> do reserved "IntString"; e <- pLExp; return (LOp LIntStr [e])

157+ <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'

158+ return (LOp LIntStr [e])

153

159

154pPrim :: LParser LExp

160pPrim :: LParser LExp

155−pPrim = do reserved "StrEq"; e <- pLExp; e' <- pLExp; return (LOp LStrEq [e, e'])

161+pPrim = do reserved "StrEq"; lchar '(';

162+ e <- pLExp; lchar ',';

163+ e' <- pLExp; lchar ')';

164+ return (LOp LStrEq [e, e'])

165+ <|> do reserved "StrLt"; lchar '('

166+ e <- pLExp; lchar ','; e' <- pLExp;

167+ lchar ')'

156− <|> do reserved "StrLt"; e <- pLExp; e' <- pLExp; return (LOp LStrLt [e, e'])

168+ return (LOp LStrLt [e, e'])

157− <|> do reserved "StrLen"; e <- pLExp; return (LOp LStrLen [e])

169+ <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';

170+ return (LOp LStrLen [e])

158 <|> do reserved "ReadString"; return (LOp LReadStr [])

171 <|> do reserved "ReadString"; return (LOp LReadStr [])

159− <|> do reserved "WriteString"; e <- pLExp; return (LOp LPrintStr [e])

172+ <|> do reserved "WriteString"; lchar '(';

173+ e <- pLExp; lchar ')'

174+ return (LOp LPrintStr [e])

175+ <|> do reserved "WriteInt"; lchar '(';

176+ e <- pLExp; lchar ')';

160− <|> do reserved "WriteInt"; e <- pLExp; return (LOp LPrintNum [e])

177+ return (LOp LPrintNum [e])

161

178

162pAlt :: LParser LAlt

179pAlt :: LParser LAlt

163pAlt = try (do x <- iName []

180pAlt = try (do x <- iName []

src/IRTS/Simplified.hs+4

@@ -130,6 +130,10 @@ scopecheck ctxt env tm = sc env tm where

130 " has arity " ++ show ar

131 [_] -> return $ SApp tc f args'

132 [] -> fail $ "Codegen error: No such variable " ++ show f

133+ sc env (SForeign l ty f args)

134+ = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

135+ return (t, a')) args

136+ return $ SForeign l ty f args'

133 sc env (SCon tag f args)

137 sc env (SCon tag f args)

134 = do args' <- mapM (scVar env) args

138 = do args' <- mapM (scVar env) args

135 case lookupCtxt Nothing f ctxt of

139 case lookupCtxt Nothing f ctxt of