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

git.iko.soy/Idris-dev

Compile foreign calls

commit3812df83c9b12ba8fb4acd8b7243de700ea80d7f authorEdwin Brady <eb@cs.st-andrews.ac.uk> dateMon 3 Sep 2012, 11:46 (14 years ago) parent168706f

4 files changed+43−16

compare with master

unifiedsplit

iif/testvm.iif+5−1 src/IRTS/CodegenC.hs+5−3 src/IRTS/LParser.hs+29−12 src/IRTS/Simplified.hs+4

iif/testvm.iif+5−1

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

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

2424 }

2525

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

27+

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

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

29+ let sval = sin(1.0) in

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

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

2832

src/IRTS/CodegenC.hs+5−3

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

2626 DbgLevel ->

2727 IO ()

2828codegenC defs out exec incs libs dbg

29− = do let tagged = addTags defs

29+ = do -- print defs

30+ let tagged = addTags defs

3031 let ctxtIn = addAlist tagged emptyContext

3132 let checked = checkDefs ctxtIn tagged

3233 case checked of

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

4748 " " ++ tmpn ++

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

4950 " -lidris_rts -o " ++ out

51+-- putStrLn cout

5052 exit <- system gcc

5153 when (exit /= ExitSuccess) $

5254 putStrLn ("FAILURE: " ++ gcc)

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

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

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

5860

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

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

6062debug _ = ""

6163

6264gccDbg DEBUG = "-g"

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

136138bcc i (FOREIGNCALL l LANG_C rty fn args)

137139 = indent i ++ creg l ++ " = " ++

138140 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)

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

141143

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

src/IRTS/LParser.hs+29−12

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

4646

4747fovm :: FilePath -> IO ()

4848fovm f = do defs <- parseFOVM f

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

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

5050

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

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

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

144144 return (LCase e alts)

145145

146146pCast :: LParser LExp

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

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

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

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

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

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

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

148+ return (LOp LFloatStr [e])

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

150+ return (LOp LStrFloat [e])

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

152+ return (LOp LFloatInt [e])

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

154+ return (LOp LIntFloat [e])

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

156+ return (LOp LStrInt [e])

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

158+ return (LOp LIntStr [e])

153159

154160pPrim :: LParser LExp

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

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

157− <|> do reserved "StrLen"; e <- pLExp; return (LOp LStrLen [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 ')'

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

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

170+ return (LOp LStrLen [e])

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

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

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

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

173+ e <- pLExp; lchar ')'

174+ return (LOp LPrintStr [e])

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

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

177+ return (LOp LPrintNum [e])

161178

162179pAlt :: LParser LAlt

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

src/IRTS/Simplified.hs+4

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

130130 " has arity " ++ show ar

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

132132 [] -> 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'

133137 sc env (SCon tag f args)

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

135139 case lookupCtxt Nothing f ctxt of