1950393 · Idris-dev · git.iko.soy

src/IRTS/Bytecode.hs+1−1

compare with master

unifiedsplit

@@ -71,7 +71,7 @@ data BC =

71 | TAILCALL Name

72

73 -- set reg to (apply string args),

74− | FOREIGNCALL Reg FDesc DExp [(FDesc, Reg)]

74+ | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)]

75

76 -- move this number of elements from TOP to BASE

77 | SLIDE Int

src/IRTS/CodegenC.hs+1−1

@@ -277,7 +277,7 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

277bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

278bcc i STOREOLD = indent i ++ "STOREOLD;\n"

279bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

280−bcc i (FOREIGNCALL l rty (DConst (Str fn)) args)

280+bcc i (FOREIGNCALL l rty (FStr fn) args)

281 = indent i ++

282 c_irts (toFType rty) (creg l ++ " = ")

283 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

src/IRTS/CodegenJavaScript.hs+1−1

@@ -1329,7 +1329,7 @@ translateBC info bc

1329 | NULL r <- bc = jsNULL info r

1330 | CALL n <- bc = jsCALL info n

1331 | TAILCALL n <- bc = jsTAILCALL info n

1332− | FOREIGNCALL r _ (DConst (Str n)) args

1332+ | FOREIGNCALL r _ (FStr n) args

1333 <- bc = jsFOREIGN info r n (map fcall args)

1334 | TOPBASE n <- bc = jsTOPBASE info n

1335 | BASETOP n <- bc = jsBASETOP info n

src/IRTS/Compiler.hs+2−1

@@ -438,7 +438,7 @@ irTerm vs env Impossible = return $ LNothing

438doForeign :: Vars -> [Name] -> [Term] -> Idris LExp

439doForeign vs env (ret : fname : world : args)

440 = do args' <- mapM splitArg args

441− fname' <- irTerm vs env fname

441+ let fname' = toFDesc fname

442 let ret' = toFDesc ret

443 return $ LForeign ret' fname' args'

444 where

@@ -448,6 +448,7 @@ doForeign vs env (ret : fname : world : args)

448 return (l', r')

449 splitArg _ = ifail "Badly formed foreign function call"

450

451+ toFDesc (Constant (Str str)) = FStr str

451 toFDesc tm

452 toFDesc tm

452 | (P _ n _, []) <- unApply tm = FCon (deNS n)

453 | (P _ n _, []) <- unApply tm = FCon (deNS n)

453 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)

454 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)

src/IRTS/Defunctionalise.hs+4−5

@@ -22,7 +22,7 @@ data DExp = DV LVar

22 | DCase CaseType DExp [DAlt]

23 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)

24 | DConst Const

25− | DForeign FDesc DExp [(FDesc, DExp)]

25+ | DForeign FDesc FDesc [(FDesc, DExp)]

26 | DOp PrimFn [DExp]

27 | DNothing -- erased value, can be compiled to anything since it'll never

28 -- be inspected

@@ -111,9 +111,8 @@ addApps defs (n, LFun _ _ args e)

111 return $ DCase up e' alts'

112 aa env (LConst c) = return $ DConst c

113 aa env (LForeign t n args)

114− = do n' <- aa env n

115− args' <- mapM (aaF env) args

114+ = do args' <- mapM (aaF env) args

116− return $ DForeign t n' args'

115+ return $ DForeign t n args'

117 aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)

116 aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)

118 aa env (LOp f args) = do args' <- mapM (aa env) args

117 aa env (LOp f args) = do args' <- mapM (aa env) args

119 return $ DOp f args'

118 return $ DOp f args'

@@ -279,7 +278,7 @@ instance Show DExp where

279 showSep "\n\t| " (map (showAlt env) alts)

278 showSep "\n\t| " (map (showAlt env) alts)

280 show' env (DConst c) = show c

279 show' env (DConst c) = show c

281 show' env (DForeign ty n args)

280 show' env (DForeign ty n args)

282− = "foreign " ++ show' env n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

281+ = "foreign " ++ show n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

283 show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

282 show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

284 show' env (DError str) = "error " ++ show str

283 show' env (DError str) = "error " ++ show str

285 show' env DNothing = "____"

284 show' env DNothing = "____"

src/IRTS/Lang.hs+4−4

@@ -30,7 +30,7 @@ data LExp = LV LVar

30 | LCase CaseType LExp [LAlt]

31 | LConst Const

32 | LForeign FDesc -- Function descriptor

33− LExp -- Return type descriptor

33+ FDesc -- Return type descriptor

34 [(FDesc, LExp)] -- first LExp is the FFI type description

35 | LOp PrimFn [LExp]

36 | LNothing

@@ -38,6 +38,7 @@ data LExp = LV LVar

38 deriving Eq

39

40data FDesc = FCon Name

41+ | FStr String

41 | FUnknown

42 | FUnknown

42 | FApp Name [FDesc]

43 | FApp Name [FDesc]

43 deriving (Show, Eq)

44 deriving (Show, Eq)

@@ -197,8 +198,7 @@ lift env (LCase up e alts) = do alts' <- mapM liftA alts

197 return (LDefaultCase e')

198 return (LDefaultCase e')

198lift env (LConst c) = return (LConst c)

199lift env (LConst c) = return (LConst c)

199lift env (LForeign t s args) = do args' <- mapM (liftF env) args

200lift env (LForeign t s args) = do args' <- mapM (liftF env) args

200− s' <- lift env s

201− return (LForeign t s' args')

201+ return (LForeign t s args')

202 where

203 liftF env (t, e) = do e' <- lift env e

204 return (t, e')

@@ -336,7 +336,7 @@ instance Show LExp where

336

337 show' env ind (LForeign ty n args) = concat

338 [ "foreign{ "

339− , show' env ind n ++ "("

339+ , show n ++ "("

340 , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)

341 , ") : "

342 , show ty

src/IRTS/Simplified.hs+1−1

@@ -24,7 +24,7 @@ data SExp = SV LVar

24 | SConst Const

25 -- Keep DExps for describing foreign things, because they get

26 -- translated differently

27− | SForeign FDesc DExp [(FDesc, LVar)]

27+ | SForeign FDesc FDesc [(FDesc, LVar)]

28 | SOp PrimFn [LVar]

29 | SNothing -- erased value, will never be inspected

30 | SError String