1950393 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Use FDesc for foreign target

FDesc can either be an application, a constructor or a string, which should be enough for describing a path to a foreign name

commit19503934ca8241fc3329cc3de4d2181287ff3c2d authorEdwin Brady <ecb10@st-andrews.ac.uk> dateTue 20 Jan 2015, 21:36 (12 years ago) parentef75f3c

7 files changed+14−14

compare with master

unifiedsplit

src/IRTS/Bytecode.hs+1−1 src/IRTS/CodegenC.hs+1−1 src/IRTS/CodegenJavaScript.hs+1−1 src/IRTS/Compiler.hs+2−1 src/IRTS/Defunctionalise.hs+4−5 src/IRTS/Lang.hs+4−4 src/IRTS/Simplified.hs+1−1

src/IRTS/Bytecode.hs+1−1

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

7171 | TAILCALL Name

7272

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

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

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

7575

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

7777 | SLIDE Int

src/IRTS/CodegenC.hs+1−1

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

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

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

279279bcc 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)

281281 = indent i ++

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

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

src/IRTS/CodegenJavaScript.hs+1−1

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

13291329 | NULL r <- bc = jsNULL info r

13301330 | CALL n <- bc = jsCALL info n

13311331 | TAILCALL n <- bc = jsTAILCALL info n

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

1332+ | FOREIGNCALL r _ (FStr n) args

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

13341334 | TOPBASE n <- bc = jsTOPBASE info n

13351335 | BASETOP n <- bc = jsBASETOP info n

src/IRTS/Compiler.hs+2−1

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

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

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

440440 = do args' <- mapM splitArg args

441− fname' <- irTerm vs env fname

441+ let fname' = toFDesc fname

442442 let ret' = toFDesc ret

443443 return $ LForeign ret' fname' args'

444444 where

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

448448 return (l', r')

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

450450

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

451452 toFDesc tm

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

453454 | (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

2222 | DCase CaseType DExp [DAlt]

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

2424 | DConst Const

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

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

2626 | DOp PrimFn [DExp]

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

2828 -- be inspected

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

111111 return $ DCase up e' alts'

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

113113 aa env (LForeign t n args)

114− = do n' <- aa env n

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

116− return $ DForeign t n' args'

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

115+ return $ DForeign t n args'

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

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

119118 return $ DOp f args'

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

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

280279 show' env (DConst c) = show c

281280 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)) ++ ")"

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

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

285284 show' env DNothing = "____"

src/IRTS/Lang.hs+4−4

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

3030 | LCase CaseType LExp [LAlt]

3131 | LConst Const

3232 | LForeign FDesc -- Function descriptor

33− LExp -- Return type descriptor

33+ FDesc -- Return type descriptor

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

3535 | LOp PrimFn [LExp]

3636 | LNothing

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

3838 deriving Eq

3939

4040data FDesc = FCon Name

41+ | FStr String

4142 | FUnknown

4243 | FApp Name [FDesc]

4344 deriving (Show, Eq)

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

197198 return (LDefaultCase e')

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

199200lift 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')

202202 where

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

204204 return (t, e')

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

336336

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

338338 [ "foreign{ "

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

339+ , show n ++ "("

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

341341 , ") : "

342342 , show ty

src/IRTS/Simplified.hs+1−1

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

2424 | SConst Const

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

2626 -- translated differently

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

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

2828 | SOp PrimFn [LVar]

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

3030 | SError String