{- ---------------------------------------------------------------------------
-- Transforms primitive FFI decls to introduce a function wrapper, which
-- is either an IO wrapper, or a pure wrapper. We need to expand all
-- type synonyms at this stage in order to tell if we have an IO result type.
-- Hence, this phase needs to be after renaming (so that the type synonym
-- information we need is available in the symbol table).
--
-- This module also writes the type of the prim to the symbol table,
-- but not the type of the wrapper, which is done later during the
-- type extraction phase (we want the compiler to at least ensure
-- that the wrapper introduced here is type correct!).
-- ------------------------------------------------------------------------- -}
module FFITrans (ffiTrans) where
import IdKind
import TokenId
import IntState
import Syntax
import State
import NT
import Id
import Extract (type2NT)
import Type.Subst(substNT)
import Util.Extra (snub)
import IExtract (freeType)
import SysDeps (packString,unpackPS)
import Maybe
type FFIMonad a = State In Out a Out
type In = ((TokenId,IdKind) -> Id) -- lookup fn
type Out = IntState
ffiTrans :: Decls Id -- input declarations
-> ((TokenId,IdKind) -> Id) -- lookup name in symbol table
-> IntState -- internal compiler state
-> (Decls Id -- modified declarations
,IntState) -- modified internal state
ffiTrans topdecls lookup state =
case ffiDecls topdecls lookup state of
(decls', state') -> (decls', state')
ffiDecls :: Decls Id -> FFIMonad (Decls Id)
ffiDecls (DeclsParse ds) =
unitS DeclsParse =>>>
(mapS ffiDecl ds >>>= unitS . concat)
ffiDecl :: Decl Id -> FFIMonad [Decl Id]
ffiDecl d@(DeclForeignImp pos callConv cname id _ cast typ x) =
examineType pos typ >>>= \(isIO,nt,typ',arity,adjarity)->
if isIO then
copyPrim id cname >>>= \(id',cname') ->
makeIWrapper pos id' arity >>>= \code->
updVar pos id' (NewType (snub (freeType typ)) [] [] [nt]) adjarity >>>
unitS [ DeclForeignImp pos callConv cname' id' adjarity cast typ' x
, DeclVarsType [(pos,id)] [] typ
, DeclFun pos id [code]
]
else
updVar pos id (NewType (snub (freeType typ)) [] [] [nt]) arity >>>
unitS [d]
ffiDecl d@(DeclForeignExp pos callConv cname id typ) =
examineType pos typ >>>= \(isIO,nt,typ',arity,adjarity)->
if isIO then
copyPrim id cname >>>= \(id',cname')->
makeEWrapper pos id arity >>>= \code->
unitS [ DeclForeignExp pos callConv cname' id' typ'
, DeclVarsType [(pos,id)] [] typ
, DeclFun pos id' [code]
]
else
updVar pos id (NewType (snub (freeType typ)) [] [] [nt]) arity >>>
unitS [d]
ffiDecl d = unitS [d]
-- For foreign imports with IO type:
-- Copy original prim to new symtable location leaving original slot
-- for the new wrapper.
-- For foreign exports with IO type:
-- Wrapped function for export is placed in new symtable location,
-- leaving original slot untouched.
-- In either case, return the new ID, together with the proper
-- C name for the foreign function (if it was originally blank, we must
-- use the Haskell name).
copyPrim :: Id -> String -> FFIMonad (Id,String)
copyPrim id cname lookup state =
case uniqueIS state of
(i, state1) ->
let newname = Qualified m (packString ('#':unpackPS name))
info = InfoVar i newname IEnone fix NoType ar
state2 = addIS i info state1
cname' = if null cname then reverse (unpackPS name) else cname
in ((i, cname'), state2)
where
(Just (InfoVar _ (Qualified m name) _ fix _ ar)) = lookupIS state id
-- Report whether the result type is IO, after expanding all type synonyms.
-- Return also the NewType representation with all expansion completed,
-- the original Type representation likewise, the real arity, and
-- a possibly padded arity. (Arity is padded from zero to one for IO
-- types, to ensure re-execution happens as expected.)
examineType :: Pos -> Type Id -> FFIMonad (Bool, NT, Type Id, Int, Int)
examineType pos t lookup state =
let
expand n@(NTvar v _) = n
expand (NTstrict nt) = NTstrict (expand nt)
expand (NTapp t1 t2) = NTapp (expand t1) (expand t2)
expand (NTcons c k nts) =
case (typeSynonymBodyI . fromJust . lookupIS state) c of
Just nt -> expand (subst nt nts)
Nothing -> NTcons c k (map expand nts)
expand _ = error "Unexpected type error in foreign decl"
subst (NewType free [] ctxs [nt]) nts = substNT (zip free nts) nt
arrow = lookup (t_Arrow,TCon)
io = lookup (tIO,TCon)
unit = lookup (t_Tuple 0,TCon)
isIO (NTcons c _ nts) | c==io = True
isIO _ = False
rmIO (NTcons c _ [nt]) | c==io = nt
rmIO nt = nt
toList (NTcons c _ nts) | c==arrow = let [a,b] = nts in a: toList b
toList (NTstrict nt) = toList nt
toList nt = [nt]
(resNT:argsNT) = (reverse . toList . expand . type2NT) t
boolIO = isIO resNT
adjustArity True 0 = 1 -- Change zero-arity (IO a) to (()->IO a)
adjustArity _ n = n
adjustArgs True [] = [mkNTcons unit []]
adjustArgs _ as = reverse as
finalNT =
foldr (\a b-> mkNTcons arrow [a,b])
(rmIO resNT) (adjustArgs boolIO argsNT)
in
( ( boolIO
, finalNT
, nt2type pos finalNT
, length argsNT
, adjustArity boolIO (length argsNT)
)
, state)
makeIWrapper :: Pos -> Id -> Int -> FFIMonad (Fun Id)
makeIWrapper pos ffn arity lookup state =
( Fun [] (Unguarded
(ExpApplication pos [ExpVar pos (lookup (t_mkIOok arity,Var))
,ExpVar pos ffn]
))
(DeclsParse [])
, state )
makeEWrapper :: Pos -> Id -> Int -> FFIMonad (Fun Id)
makeEWrapper pos hfn arity lookup state =
let (vs, state1) = uniqueISs state [1..arity]
args = map (ExpVar pos . snd) vs
in
( Fun args (Unguarded
(ExpApplication pos
[ExpVar pos (lookup (tunsafePerformIO,Var))
,ExpApplication pos (ExpVar pos hfn:args)]
))
(DeclsParse [])
, state1 )
-- updVar :: Pos -> Int -> NewType -> FFIMonad ()
updVar pos id nt ar lookup state =
(updVarArity pos id ar . updVarNT pos id nt) state
-- nt2type reverses the type2NT translation
nt2type :: Pos -> NT -> Type Id
nt2type p (NTapp t1 t2) = TypeApp (nt2type p t1) (nt2type p t2)
nt2type p (NTcons c _ ts) = TypeCons p c (map (nt2type p) ts)
nt2type p (NTstrict t) = TypeStrict p (nt2type p t)
nt2type p (NTvar v _) = TypeVar p v
nt2type p _ = error "FFI transformation: nt2type"
|
