~jojo/Carth

ref: ee5251b9b8bf725c1d5499fedf9c9671308fa476 Carth/src/Extern.hs -rw-r--r-- 8.4 KiB
ee5251b9JoJo Glob exports in AST modules -- minor refactor / cleanup 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
{-# LANGUAGE OverloadedStrings, LambdaCase, TupleSections, FlexibleContexts #-}

-- | Codegeneration related to external C function declarations
--
--   `extern` forms are translated pretty literally to extern declarations,
--   taking the C ABI into account when deciding whether to pass a ref on the
--   stack or in registers, etc. Further, ad wrapper-closure is generated around
--   the function, which translates the calling convention from C to whatever we
--   use internally (e.g. tailcc or fastcc), adds a dummy `captures` parameter
--   to make it compatible with all other function signatures, and finally it
--   adds currying.
--
--   One might think that simply declaring all function definitions and function
--   calls as being of the same "ccc" LLVM calling convention would allow us to
--   pass arguments and return results as we please, and everything will be
--   compatible? I sure did, however, that is not the case. To be compatible
--   with C FFIs, we also have to actually conform to the C calling convention,
--   which contains a bunch of details about how more complex types should be
--   passed and returned. Currently, we pass and return simple types by value,
--   and complex types by reference (param by ref, return via sret param).
--
--   See the definition of `passByRef` for up-to-date details about which types
--   are passed how.
module Extern (withExternSigs, genExterns, genBuiltins, callExtern) where

import LLVM.AST
import LLVM.AST.ParameterAttribute
import qualified LLVM.AST.Constant as LLConst
import Control.Monad.Writer
import qualified Data.Map as Map
import Lens.Micro.Platform (view, to, assign)
import LLVM.AST.Typed
import qualified LLVM.AST.Type as LLType
import Data.Functor
import Data.Bifunctor

import Misc
import SrcPos
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import Gen


withExternSigs :: [(String, M.Type, SrcPos)] -> Gen' a -> Gen' a
withExternSigs es ga = do
    es' <- forM es $ \(name, t, _) -> do
        t' <- genType' t
        pure
            ( TypedVar name t
            , ConstantOperand $ LLConst.GlobalReference
                (LLType.ptr t')
                (mkName ("_wrapper_" ++ name))
            )
    augment env (Map.fromList es') ga

genExterns :: [(String, M.Type, SrcPos)] -> Gen' [Definition]
genExterns = fmap join . mapM genExtern

genExtern :: (String, M.Type, SrcPos) -> Gen' [Definition]
genExtern (name, t, pos) = do
    let (pts, rt) = uncurryType t
    when (null pts) $ ice "genExtern of non-function"
    let anon = mkName ""
    pts' <- mapM genType' pts
    ps <- forM pts' $ \pt' -> passByRef' pt' <&> \case
        True -> Parameter (LLType.ptr pt') anon [ByVal]
        False -> Parameter pt' anon []
    rt' <- genRetType' rt
    (rt'', ps') <- passByRef' rt' <&> \case
        True -> (LLType.void, Parameter (LLType.ptr rt') anon [SRet] : ps)
        False -> (rt', ps)
    let externDef = GlobalDefinition (externFunc (mkName name) ps' rt'' [] [])
    wrapperDefs <- genWrapper pos name rt' pts
    pure (externDef : wrapperDefs)

genWrapper :: SrcPos -> String -> Type -> [M.Type] -> Gen' [Definition]
genWrapper pos externName rt paramTs =
    case (zipWith (TypedVar . ("x" ++) . show) [1 :: Word ..] paramTs) of
        [] -> ice "genWrapper of empty param list"
        (firstParam : restParams) -> do
            let genCallExtern :: [TypedVar] -> Gen Val
                genCallExtern vars = do
                    ts <- mapM (\(TypedVar _ t) -> genType t) vars
                    vars' <- mapM lookupVar vars
                    as <- forM (zip vars' ts) $ \(v, t) -> passByRef t >>= \case
                        True -> fmap (, [ByVal]) (getVar v)
                        False -> fmap (, []) (getLocal v)
                    let ats = map (typeOf . fst) as
                    let fname = mkName externName
                    passByRef rt >>= \case
                        True -> do
                            out <- emitReg "out" (alloca rt)
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType
                                        LLType.void
                                        (typeOf out : ats)
                                        False
                                    )
                                    fname
                            emitDo $ callExtern f ((out, [SRet]) : as)
                            pure (VVar out)
                        False ->
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType rt ats False)
                                    fname
                            in
                                if rt == LLType.void
                                    then emitDo (callExtern f as)
                                        $> VLocal litUnit
                                    else fmap VLocal $ emitAnonReg $ WithRetType
                                        (callExtern f as)
                                        rt
            let
                genWrapper' fvs ps' = do
                    r <- getLocal =<< case ps' of
                        [] -> genCallExtern fvs
                        (p : ps) -> do
                            pts <- mapM (\(TypedVar _ t) -> genType t) ps
                            let bt = foldr closureType rt pts
                            genLambda
                                fvs
                                p
                                (genWrapper' (fvs ++ [p]) ps $> (), bt)
                    if typeOf r == typeUnit
                        then commitFinalFuncBlock retVoid $> LLType.void
                        else commitFinalFuncBlock (ret r) $> typeOf r
            let wrapperName = "_wrapper_" ++ externName
            assign lambdaParentFunc (Just wrapperName)
            let fname = mkName (wrapperName ++ "_func")
            (f, gs) <-
                locallySet srcPos (Just pos)
                    $ genFunDef
                        ( fname
                        , []
                        , pos
                        , firstParam
                        , genWrapper' [firstParam] restParams
                        )
            let fref = LLConst.GlobalReference (LLType.ptr (typeOf f)) fname
            let captures = LLConst.Null (LLType.ptr typeUnit)
            let closure = litStruct [captures, fref]
            let closureDef = simpleGlobVar
                    (mkName ("_wrapper_" ++ externName))
                    (typeOf closure)
                    closure
            pure (GlobalDefinition closureDef : GlobalDefinition f : gs)

uncurryType :: M.Type -> ([M.Type], M.Type)
uncurryType = \case
    M.TFun a b -> first (a :) (uncurryType b)
    t -> ([], t)

passByRef :: Type -> Gen Bool
passByRef = lift . passByRef'

-- NOTE: This post is helpful:
--       https://stackoverflow.com/questions/42411819/c-on-x86-64-when-are-structs-classes-passed-and-returned-in-registers
--       Also, official docs:
--       https://software.intel.com/sites/default/files/article/402129/mpx-linux64-abi.pdf
--       particularly section 3.2.3 Parameter Passing (p18).
passByRef' :: Type -> Gen' Bool
passByRef' = \case
    NamedTypeReference x -> view (dataTypes . to (Map.lookup x)) >>= \case
        Just ts -> passByRef' (typeStruct ts)
        Nothing ->
            ice $ "passByRef': No dataType for NamedTypeReference " ++ show x
    -- Simple scalar types. They go in registers.
    VoidType -> pure False
    IntegerType _ -> pure False
    PointerType _ _ -> pure False
    FloatingPointType _ -> pure False
    -- Functions are not POD (Plain Ol' Data), so they are passed on the stack.
    FunctionType _ _ _ -> pure True
    -- TODO: Investigate how exactly SIMD vectors are to be passed when/if we
    --       ever add support for that in the rest of the compiler.
    VectorType _ _ -> pure True
    -- Aggregate types can either be passed on stack or in regs, depending on
    -- what they contain.
    t@(StructureType _ us) -> do
        size <- sizeof t
        if size > 16 then pure True else fmap or (mapM passByRef' us)
    ArrayType _ u -> do
        size <- sizeof u
        if size > 16 then pure True else passByRef' u
    -- N/A
    MetadataType -> ice "passByRef of MetadataType"
    LabelType -> ice "passByRef of LabelType"
    TokenType -> ice "passByRef of TokenType"