diff --git a/DDC/Core/Llvm/Convert.hs b/DDC/Core/Llvm/Convert.hs --- a/DDC/Core/Llvm/Convert.hs +++ b/DDC/Core/Llvm/Convert.hs @@ -4,41 +4,26 @@ , convertType , convertSuperType) where -import DDC.Core.Llvm.Convert.Prim +import DDC.Core.Llvm.Convert.Super import DDC.Core.Llvm.Convert.Type -import DDC.Core.Llvm.Convert.Atom -import DDC.Core.Llvm.Convert.Erase -import DDC.Core.Llvm.Metadata.Tbaa import DDC.Core.Llvm.LlvmM import DDC.Llvm.Syntax import DDC.Core.Salt.Platform import DDC.Core.Compounds -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Type.Predicates -import DDC.Base.Pretty hiding (align) -import DDC.Data.ListUtils import Control.Monad.State.Strict (evalState) import Control.Monad.State.Strict (gets) import Control.Monad -import Data.Maybe -import Data.Sequence (Seq, (<|), (|>), (><)) import Data.Map (Map) -import Data.Set (Set) import qualified DDC.Llvm.Transform.Clean as Llvm import qualified DDC.Llvm.Transform.LinkPhi as Llvm import qualified DDC.Core.Salt as A -import qualified DDC.Core.Salt.Name as A import qualified DDC.Core.Module as C import qualified DDC.Core.Exp as C import qualified DDC.Type.Env as Env import qualified DDC.Core.Simplifier as Simp import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Seq --- Module --------------------------------------------------------------------- -- | Convert a Salt module to LLVM. -- -- If anything goes wrong in the convertion then this function will @@ -49,19 +34,22 @@ = {-# SCC convertModule #-} let prims = primDeclsMap platform - state = llvmStateInit platform prims + state = llvmStateInit platform mm prims -- Add extra Const and Distinct witnesses where possible. -- This helps us produce better LLVM metat data. - mmElab = evalState (Simp.applySimplifier - A.profile Env.empty Env.empty - (Simp.Trans Simp.Elaborate) mm) - state + mmElab = Simp.result + $ evalState (Simp.applySimplifier + A.profile Env.empty Env.empty + (Simp.Trans Simp.Elaborate) mm) + state + stateElab = state { llvmStateModule = mmElab } + -- Convert to LLVM. -- The result contains ISet and INop meta instructions that need to be -- cleaned out. We also need to fixup the labels in IPhi instructions. - mmRaw = evalState (convModuleM mmElab) state + mmRaw = evalState (convModuleM mmElab) stateElab -- Inline the ISet meta instructions and drop INops. -- This gives us code that the LLVM compiler will accept directly. @@ -80,52 +68,53 @@ | ([C.LRec bxs], _) <- splitXLets $ C.moduleBody mm = do platform <- gets llvmStatePlatform - -- The initial environments due to imported names. - let kenv = C.moduleKindEnv mm - let tenv = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs) - - -- Names of exported functions. - -- We use a different linkage for exported functions. - let nsExports = Set.fromList $ Map.keys $ C.moduleExportTypes mm - - -- Forward declarations for imported functions. - let Just importDecls - = sequence - $ [ importedFunctionDeclOfType platform kenv External n t - | (n, t) <- Map.elems $ C.moduleImportTypes mm ] - - -- Add RTS def ------------------------------------------------- - -- If this is the main module then we need to declare - -- the global RTS state. - let isMainModule - = C.moduleName mm == C.ModuleName ["Main"] + -- Globals for the runtime -------------- + -- If this is the main module then we define the globals + -- for the runtime system at top-level. -- Holds the pointer to the current top of the heap. -- This is the byte _after_ the last byte used by an object. - let vHeapTop = Var (NameGlobal "_DDC_Runtime_heapTop") (tAddr platform) + let vHeapTop = Var (NameGlobal "_DDC__heapTop") (tAddr platform) -- Holds the pointer to the maximum heap. -- This is the byte _after_ the last byte avaiable in the heap. - let vHeapMax = Var (NameGlobal "_DDC_Runtime_heapMax") (tAddr platform) + let vHeapMax = Var (NameGlobal "_DDC__heapMax") (tAddr platform) - let rtsGlobals - | isMainModule + let globalsRts + | C.moduleName mm == C.ModuleName ["Main"] = [ GlobalStatic vHeapTop (StaticLit (LitInt (tAddr platform) 0)) , GlobalStatic vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ] | otherwise = [ GlobalExternal vHeapTop , GlobalExternal vHeapMax ] + + -- Import external symbols -------------- + let kenv = C.moduleKindEnv mm + let tenv = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs) - --------------------------------------------------------------- + let Just importDecls + = sequence + $ [ importedFunctionDeclOfType platform kenv + isrc + (lookup n (C.moduleExportValues mm)) + n + (C.typeOfImportSource isrc) + | (n, isrc) <- C.moduleImportValues mm ] + + + -- Super-combinator definitions --------- + -- This is the code for locally defined functions. (functions, mdecls) <- liftM unzip - $ mapM (uncurry (convSuperM nsExports kenv tenv)) bxs + $ mapM (uncurry (convSuperM kenv tenv)) bxs + + -- Paste everything together ------------ return $ Module { modComments = [] , modAliases = [aObj platform] - , modGlobals = rtsGlobals + , modGlobals = globalsRts , modFwdDecls = primDecls platform ++ importDecls , modFuncs = functions , modMDecls = concat mdecls } @@ -133,7 +122,8 @@ | otherwise = die "Invalid module" --- | Global variables used directly by the converted code. +-- | C library functions that are used directly by the generated code without +-- having an import declaration in the header of the converted module. primDeclsMap :: Platform -> Map String FunctionDecl primDeclsMap pp = Map.fromList @@ -158,572 +148,4 @@ , declParamListType = FixedArgs , declParams = [] , declAlign = AlignBytes (platformAlignBytes pp) } ] - - --- Super ---------------------------------------------------------------------- --- | Convert a top-level supercombinator to a LLVM function. --- Region variables are completely stripped out. -convSuperM - :: Set A.Name -- ^ Names exported from this module. - -> KindEnv A.Name - -> TypeEnv A.Name - -> C.Bind A.Name -- ^ Bind of the top-level super. - -> C.Exp () A.Name -- ^ Super body. - -> LlvmM (Function, [MDecl]) - -convSuperM nsExports kenv tenv bSuper@(C.BName nTop@(A.NameVar strTop) tSuper) x - | Just (bfsParam, xBody) <- takeXLamFlags x - = do - platform <- gets llvmStatePlatform - - -- Sanitise the super name so we can use it as a symbol - -- in the object code. - let nTop' = A.sanitizeGlobal strTop - - -- Add parameters to environments. - let bfsParam' = eraseWitBinds bfsParam - let bsParamType = [b | (True, b) <- bfsParam'] - let bsParamValue = [b | (False, b) <- bfsParam'] - - let kenv' = Env.extends bsParamType kenv - let tenv' = Env.extends (bSuper : bsParamValue) tenv - mdsup <- deriveMD nTop' x - - -- Split off the argument and result types of the super. - let (tsParam, tResult) - = convertSuperType platform kenv tSuper - - -- Make parameter binders. - let align = AlignBytes (platformAlignBytes platform) - - -- Declaration of the super. - let decl - = FunctionDecl - { declName = nTop' - - -- Set internal linkage for non-exported functions so that they - -- they won't conflict with functions of the same name that - -- might be defined in other modules. - , declLinkage - = if Set.member nTop nsExports - then External - else Internal - - -- ISSUE #266: Tailcall optimisation doesn't work for exported functions. - -- Using fast calls for non-exported functions enables the - -- LLVM tailcall optimisation. We can't enable this for exported - -- functions as well because we don't distinguish between DDC - -- generated functions and functions from the C libararies in - -- our import specifications. We need a proper FFI system so that - -- we can get tailcalls for exported functions as well. - , declCallConv - = if Set.member nTop nsExports - then CC_Ccc - else CC_Fastcc - - , declReturnType = tResult - , declParamListType = FixedArgs - , declParams = [Param t [] | t <- tsParam] - , declAlign = align } - - -- Convert function body to basic blocks. - label <- newUniqueLabel "entry" - blocks <- convBodyM BodyTop kenv' tenv' mdsup Seq.empty label Seq.empty xBody - - -- Build the function. - return $ ( Function - { funDecl = decl - , funParams = map nameOfParam $ filter (not . isBNone) bsParamValue - , funAttrs = [] - , funSection = SectionAuto - , funBlocks = Seq.toList blocks } - , decls mdsup ) - - -convSuperM _ _ _ _ _ - = die "Invalid super" - - --- | Take the string name to use for a function parameter. -nameOfParam :: C.Bind A.Name -> String -nameOfParam bb - = case bb of - C.BName (A.NameVar n) _ - -> A.sanitizeName n - - _ -> die $ "Invalid parameter name: " ++ show bb - - --- Body ----------------------------------------------------------------------- --- | What context we're doing this conversion in. -data BodyContext - -- | Conversion at the top-level of a function. - -- The expresison being converted must eventually pass control. - = BodyTop - - -- | In a nested context, like in the right of a let-binding. - -- The expression should produce a value that we assign to this - -- variable, then jump to the provided label to continue evaluation. - | BodyNest Var Label - deriving Show - - --- | Convert a function body to LLVM blocks. -convBodyM - :: BodyContext -- ^ Context of this conversion. - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> Seq Block -- ^ Previous blocks. - -> Label -- ^ Id of current block. - -> Seq AnnotInstr -- ^ Instrs in current block. - -> C.Exp () A.Name -- ^ Expression being converted. - -> LlvmM (Seq Block) -- ^ Final blocks of function body. - -convBodyM context kenv tenv mdsup blocks label instrs xx - = do pp <- gets llvmStatePlatform - case xx of - - -- Control transfer instructions ----------------- - -- Void return applied to a literal void constructor. - -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx - , A.PrimControl A.PrimControlReturn <- p - , [C.XType _, C.XCon _ dc] <- xs - , Just A.NameLitVoid <- takeNameOfDaCon dc - -> return $ blocks - |> Block label - (instrs |> (annotNil $ IReturn Nothing)) - - -- Void return applied to some other expression. - -- We still have to eval the expression, but it returns no value. - -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx - , A.PrimControl A.PrimControlReturn <- p - , [C.XType t, x2] <- xs - , isVoidT t - -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2 - return $ blocks - |> Block label - (instrs >< (instrs2 |> (annotNil $ IReturn Nothing))) - - -- Return a value. - -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx - , A.PrimControl A.PrimControlReturn <- p - , [C.XType t, x] <- xs - -> do let t' = convertType pp kenv t - vDst <- newUniqueVar t' - is <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x - return $ blocks - |> Block label - (instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst))))) - - -- Fail and abort the program. - -- Allow this inside an expression as well as from the top level. - C.XApp{} - | Just (A.NamePrimOp p, xs) <- takeXPrimApps xx - , A.PrimControl A.PrimControlFail <- p - , [C.XType _tResult] <- xs - -> let iFail = ICall Nothing CallTypeStd Nothing - TVoid (NameGlobal "abort") [] [] - - iSet = case context of - BodyTop -> INop - BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst)) - - block = Block label - $ instrs |> annotNil iSet - |> annotNil iFail - |> annotNil IUnreachable - - - in return $ blocks |> block - - - -- Calls ----------------------------------------- - -- Tailcall a function. - -- We must be at the top-level of the function. - C.XApp{} - | Just (A.NamePrimOp p, args) <- takeXPrimApps xx - , A.PrimCall (A.PrimCallTail arity) <- p - , _tsArgs <- take arity args - , C.XType tResult : xFunTys : xsArgs <- drop arity args - , Just (xFun, _xsTys) <- takeXApps xFunTys - , Just (Var nFun _) <- takeGlobalV pp kenv tenv xFun - , Just xsArgs' <- sequence $ map (mconvAtom pp kenv tenv) xsArgs - -> if isVoidT tResult - -- Tailcalled function returns void. - then do return $ blocks - |> (Block label $ instrs - |> (annotNil $ ICall Nothing CallTypeTail Nothing - (convertType pp kenv tResult) nFun xsArgs' []) - |> (annotNil $ IReturn Nothing)) - - -- Tailcalled function returns an actual value. - else do let tResult' = convertType pp kenv tResult - vDst <- newUniqueVar tResult' - return $ blocks - |> (Block label $ instrs - |> (annotNil $ ICall (Just vDst) CallTypeTail Nothing - (convertType pp kenv tResult) nFun xsArgs' []) - |> (annotNil $ IReturn (Just (XVar vDst)))) - - - -- Assignment ------------------------------------ - - -- A statement of type void does not produce a value. - C.XLet _ (C.LLet (C.BNone t) x1) x2 - | isVoidT t - -> do instrs' <- convExpM ExpTop pp kenv tenv mdsup x1 - convBodyM context kenv tenv mdsup blocks label - (instrs >< instrs') x2 - - -- A non-void let-expression. - -- In C we can just drop a computed value on the floor, - -- but the LLVM compiler needs an explicit name for it. - -- Add the required name then call ourselves again. - C.XLet a (C.LLet (C.BNone t) x1) x2 - | not $ isVoidT t - -> do - n <- newUnique - let b = C.BName (A.NameVar ("_dummy" ++ show n)) t - - convBodyM context kenv tenv mdsup blocks label instrs - (C.XLet a (C.LLet b x1) x2) - - -- Variable assigment from a case-expression. - C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) - (C.XCase _ xScrut alts)) - x2 - -> do - let t' = convertType pp kenv t - - -- Assign result of case to this variable. - let n' = A.sanitizeName n - let vCont = Var (NameLocal n') t' - - -- Label to jump to continue evaluating 'x1' - lCont <- newUniqueLabel "cont" - - let context' = BodyNest vCont lCont - blocksCase <- convCaseM context' pp kenv tenv mdsup - label instrs xScrut alts - - let tenv' = Env.extend b tenv - convBodyM context kenv tenv' mdsup - (blocks >< blocksCase) - lCont - Seq.empty - x2 - - -- Variable assignment from an non-case expression. - C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) x1) x2 - -> do let tenv' = Env.extend b tenv - let n' = A.sanitizeName n - - let t' = convertType pp kenv t - let dst = Var (NameLocal n') t' - instrs' <- convExpM (ExpAssign dst) pp kenv tenv mdsup x1 - convBodyM context kenv tenv' mdsup blocks label (instrs >< instrs') x2 - - - -- Letregions ------------------------------------ - C.XLet _ (C.LLetRegions b _) x2 - -> do let kenv' = Env.extends b kenv - convBodyM context kenv' tenv mdsup blocks label instrs x2 - - -- Case ------------------------------------------ - C.XCase _ xScrut alts - -> do blocks' <- convCaseM context pp kenv tenv mdsup - label instrs xScrut alts - - return $ blocks >< blocks' - - -- Cast ------------------------------------------- - C.XCast _ _ x - -> convBodyM context kenv tenv mdsup blocks label instrs x - - _ - | BodyNest vDst label' <- context - -> do instrs' <- convExpM (ExpAssign vDst) pp kenv tenv mdsup xx - return $ blocks >< Seq.singleton (Block label - (instrs >< (instrs' |> (annotNil $ IBranch label')))) - - | otherwise - -> die $ renderIndent - $ text "Invalid body statement " - <$> ppr xx - - --- Exp ------------------------------------------------------------------------ --- | What context we're doing this conversion in. -data ExpContext - -- | Conversion at the top-level of the function. - -- We don't have a variable to assign the result to, - -- so this must be a statement that transfers control - = ExpTop - - -- | Conversion in a context that expects a value. - -- We evaluate the expression and assign the result to this variable. - | ExpAssign Var - deriving Show - - --- | Take any assignable variable from an `ExpContext`. -varOfExpContext :: ExpContext -> Maybe Var -varOfExpContext xc - = case xc of - ExpTop -> Nothing - ExpAssign var -> Just var - - --- | Convert a simple Core expression to LLVM instructions. --- --- This only works for variables, literals, and full applications of --- primitive operators. The client should ensure the program is in this form --- before converting it. The result is just a sequence of instructions, - -- so there are no new labels to jump to. -convExpM - :: ExpContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> C.Exp () A.Name -- ^ Expression to convert. - -> LlvmM (Seq AnnotInstr) - -convExpM context pp kenv tenv mdsup xx - = case xx of - C.XVar _ u@(C.UName (A.NameVar n)) - | Just t <- Env.lookup u tenv - , ExpAssign vDst <- context - -> do let n' = A.sanitizeName n - let t' = convertType pp kenv t - return $ Seq.singleton $ annotNil - $ ISet vDst (XVar (Var (NameLocal n') t')) - - C.XCon _ dc - | Just n <- takeNameOfDaCon dc - , ExpAssign vDst <- context - -> case n of - A.NameLitNat i - -> return $ Seq.singleton $ annotNil - $ ISet vDst (XLit (LitInt (tNat pp) i)) - - A.NameLitInt i - -> return $ Seq.singleton $ annotNil - $ ISet vDst (XLit (LitInt (tInt pp) i)) - - A.NameLitWord w bits - -> return $ Seq.singleton $ annotNil - $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w)) - - _ -> die "Invalid literal" - - C.XApp{} - -- Call to primop. - | Just (C.XVar _ (C.UPrim (A.NamePrimOp p) tPrim), args) <- takeXApps xx - -> convPrimCallM pp kenv tenv mdsup - (varOfExpContext context) - p tPrim args - - -- Call to top-level super. - | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx - , Just (Var nFun _) <- takeGlobalV pp kenv tenv xFun - , Just xsArgs_value' <- sequence $ map (mconvAtom pp kenv tenv) - $ eraseTypeWitArgs xsArgs - , Just tSuper <- Env.lookup u tenv - -> let (_, tResult) = convertSuperType pp kenv tSuper - in return $ Seq.singleton $ annotNil - $ ICall (varOfExpContext context) CallTypeStd Nothing - tResult nFun xsArgs_value' [] - - C.XCast _ _ x - -> convExpM context pp kenv tenv mdsup x - - _ -> die $ "Invalid expression " ++ show xx - - --- Case ----------------------------------------------------------------------- -convCaseM - :: BodyContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> Label -- label of current block - -> Seq AnnotInstr -- intrs to prepend to initial block. - -> C.Exp () A.Name - -> [C.Alt () A.Name] - -> LlvmM (Seq Block) - -convCaseM context pp kenv tenv mdsup label instrs xScrut alts - | Just vScrut'@Var{} <- takeLocalV pp kenv tenv xScrut - = do - -- Convert all the alternatives. - -- If we're in a nested context we'll also get a block to join the - -- results of each alternative. - (alts', blocksJoin) - <- convAlts context pp kenv tenv mdsup alts - - -- Build the switch --------------- - -- Determine what default alternative to use for the instruction. - (lDefault, blocksDefault) - <- case last alts' of - AltDefault l bs -> return (l, bs) - AltCase _ l bs -> return (l, bs) - - -- Alts that aren't the default. - let Just altsTable = takeInit alts' - - -- Build the jump table of non-default alts. - let table = mapMaybe takeAltCase altsTable - let blocksTable = join $ fmap altResultBlocks $ Seq.fromList altsTable - - let switchBlock - = Block label - $ instrs - |> (annotNil $ ISwitch (XVar vScrut') lDefault table) - - return $ switchBlock - <| (blocksTable >< blocksDefault >< blocksJoin) - -convCaseM _ _ _ _ _ _ _ _ _ - = die "Invalid case expression" - - --- Alts ----------------------------------------------------------------------- -convAlts - :: BodyContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> [C.Alt () A.Name] - -> LlvmM ([AltResult], Seq Block) - --- Alternatives are at top level. -convAlts BodyTop - _pp kenv tenv mdsup alts - = do - alts' <- mapM (convAltM BodyTop kenv tenv mdsup) alts - return (alts', Seq.empty) - - --- If we're doing a branch inside a let-binding we need to add a join --- point to collect the results from each altenative before continuing --- on to evaluate the rest. -convAlts (BodyNest vDst lCont) - _pp kenv tenv mdsup alts - = do - let tDst' = typeOfVar vDst - - -- Label of the block that does the join. - lJoin <- newUniqueLabel "join" - - -- Convert all the alternatives, - -- assiging their results into separate vars. - (vDstAlts, alts'@(_:_)) - <- liftM unzip - $ mapM (\alt -> do - vDst' <- newUniqueNamedVar "alt" tDst' - alt' <- convAltM (BodyNest vDst' lJoin) kenv tenv mdsup alt - return (vDst', alt')) - $ alts - - -- A block to join the result from each alternative. - -- Trying to keep track of which block a variable is defined in is - -- too hard when we have nested join points. - -- Instead, we set the label here to 'unknown' and fix this up in the - -- Clean transform. - let blockJoin - = Block lJoin - $ Seq.fromList $ map annotNil - [ IPhi vDst [ (XVar vDstAlt, Label "unknown") - | vDstAlt <- vDstAlts ] - , IBranch lCont ] - - return (alts', Seq.singleton blockJoin) - - --- Alt ------------------------------------------------------------------------ --- | Holds the result of converting an alternative. -data AltResult - = AltDefault Label (Seq Block) - | AltCase Lit Label (Seq Block) - - --- | Convert a case alternative to LLVM. --- --- This only works for zero-arity constructors. --- The client should extrac the fields of algebraic data objects manually. -convAltM - :: BodyContext -- ^ Context we're converting in. - -> KindEnv A.Name -- ^ Kind environment. - -> TypeEnv A.Name -- ^ Type environment. - -> MDSuper -- ^ Meta-data for the enclosing super. - -> C.Alt () A.Name -- ^ Alternative to convert. - -> LlvmM AltResult - -convAltM context kenv tenv mdsup aa - = do pp <- gets llvmStatePlatform - case aa of - C.AAlt C.PDefault x - -> do label <- newUniqueLabel "default" - blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x - return $ AltDefault label blocks - - C.AAlt (C.PData dc []) x - | Just n <- takeNameOfDaCon dc - , Just lit <- convPatName pp n - -> do label <- newUniqueLabel "alt" - blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x - return $ AltCase lit label blocks - - _ -> die "Invalid alternative" - - --- | Convert a constructor name from a pattern to a LLVM literal. --- --- Only integral-ish types can be used as patterns, for others --- such as Floats we rely on the Lite transform to have expanded --- cases on float literals into a sequence of boolean checks. -convPatName :: Platform -> A.Name -> Maybe Lit -convPatName pp name - = case name of - A.NameLitBool True -> Just $ LitInt (TInt 1) 1 - A.NameLitBool False -> Just $ LitInt (TInt 1) 0 - - A.NameLitNat i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i - - A.NameLitInt i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i - - A.NameLitWord i bits - | elem bits [8, 16, 32, 64] - -> Just $ LitInt (TInt $ fromIntegral bits) i - - A.NameLitTag i -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i - - _ -> Nothing - - --- | Take the blocks from an `AltResult`. -altResultBlocks :: AltResult -> Seq Block -altResultBlocks aa - = case aa of - AltDefault _ blocks -> blocks - AltCase _ _ blocks -> blocks - - --- | Take the `Lit` and `Label` from an `AltResult` -takeAltCase :: AltResult -> Maybe (Lit, Label) -takeAltCase (AltCase lit label _) = Just (lit, label) -takeAltCase _ = Nothing diff --git a/DDC/Core/Llvm/Convert/Atom.hs b/DDC/Core/Llvm/Convert/Atom.hs --- a/DDC/Core/Llvm/Convert/Atom.hs +++ b/DDC/Core/Llvm/Convert/Atom.hs @@ -1,3 +1,4 @@ + module DDC.Core.Llvm.Convert.Atom ( mconvAtom , mconvAtoms @@ -7,11 +8,14 @@ import DDC.Llvm.Syntax import DDC.Core.Llvm.Convert.Type import DDC.Core.Salt.Platform -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Salt as A -import qualified DDC.Core.Salt.Name as A -import qualified DDC.Core.Exp as C +import DDC.Base.Pretty +import Control.Monad +import DDC.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Convert as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C -- Atoms ---------------------------------------------------------------------- @@ -38,11 +42,10 @@ -- Literals. C.XCon _ dc - | C.DaConNamed n <- C.daConName dc - , t <- C.daConType dc + | C.DaConPrim n t <- dc -> case n of - A.NameLitBool bool - -> let i | bool = 1 + A.NameLitBool b + -> let i | b = 1 | otherwise = 0 in Just $ XLit (LitInt (convertType pp kenv t) i) @@ -71,10 +74,8 @@ -- | Take a variable from an expression as a local var, if any. takeLocalV :: Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> C.Exp a A.Name - -> Maybe Var + -> KindEnv A.Name -> TypeEnv A.Name + -> C.Exp a A.Name -> Maybe Var takeLocalV pp kenv tenv xx = case xx of @@ -86,16 +87,20 @@ -- | Take a variable from an expression as a local var, if any. takeGlobalV - :: Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> C.Exp a A.Name - -> Maybe Var + :: Platform -> C.Module () A.Name + -> KindEnv A.Name -> TypeEnv A.Name + -> C.Exp a A.Name -> Maybe Var -takeGlobalV pp kenv tenv xx - = case xx of - C.XVar _ u@(C.UName (A.NameVar str)) - | Just t <- Env.lookup u tenv - -> Just $ Var (NameGlobal str) (convertType pp kenv t) - _ -> Nothing +takeGlobalV pp mm kenv tenv xx + | C.XVar _ u@(C.UName nSuper) <- xx + , Just t <- Env.lookup u tenv + = let + mImport = lookup nSuper (C.moduleImportValues mm) + mExport = lookup nSuper (C.moduleExportValues mm) + Just str = liftM renderPlain $ A.seaNameOfSuper mImport mExport nSuper + + in Just $ Var (NameGlobal str) (convertType pp kenv t) + + | otherwise + = Nothing diff --git a/DDC/Core/Llvm/Convert/Exp.hs b/DDC/Core/Llvm/Convert/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp.hs @@ -0,0 +1,503 @@ + +module DDC.Core.Llvm.Convert.Exp + ( BodyContext (..) + , convBodyM) +where +import DDC.Core.Llvm.Convert.Prim +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Llvm.Convert.Atom +import DDC.Core.Llvm.Convert.Erase +import DDC.Core.Llvm.Metadata.Tbaa +import DDC.Core.Llvm.LlvmM +import DDC.Llvm.Syntax +import DDC.Core.Salt.Platform +import DDC.Core.Compounds +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Base.Pretty hiding (align) +import DDC.Data.ListUtils +import Control.Monad.State.Strict (gets) +import Control.Monad +import Data.Maybe +import Data.Sequence (Seq, (<|), (|>), (><)) +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Convert as A +import qualified DDC.Core.Exp as C +import qualified DDC.Type.Env as Env +import qualified Data.Sequence as Seq + + +-- Body ------------------------------------------------------------------------------------------- +-- | What context we're doing this conversion in. +data BodyContext + -- | Conversion at the top-level of a function. + -- The expresison being converted must eventually pass control. + = BodyTop + + -- | In a nested context, like in the right of a let-binding. + -- The expression should produce a value that we assign to this + -- variable, then jump to the provided label to continue evaluation. + | BodyNest Var Label + deriving Show + + +-- | Convert a function body to LLVM blocks. +convBodyM + :: BodyContext -- ^ Context of this conversion. + -> KindEnv A.Name + -> TypeEnv A.Name + -> MDSuper + -> Seq Block -- ^ Previous blocks. + -> Label -- ^ Id of current block. + -> Seq AnnotInstr -- ^ Instrs in current block. + -> C.Exp () A.Name -- ^ Expression being converted. + -> LlvmM (Seq Block) -- ^ Final blocks of function body. + +convBodyM context kenv tenv mdsup blocks label instrs xx + = do pp <- gets llvmStatePlatform + mm <- gets llvmStateModule + case xx of + + -- Control transfer instructions ----------------- + -- Void return applied to a literal void constructor. + -- We must be at the top-level of the function. + C.XApp{} + | BodyTop <- context + , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + , A.PrimControl A.PrimControlReturn <- p + , [C.XType{}, C.XCon _ dc] <- xs + , Just A.NameLitVoid <- takeNameOfDaCon dc + -> return $ blocks + |> Block label + (instrs |> (annotNil $ IReturn Nothing)) + + -- Void return applied to some other expression. + -- We still have to eval the expression, but it returns no value. + -- We must be at the top-level of the function. + C.XApp{} + | BodyTop <- context + , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + , A.PrimControl A.PrimControlReturn <- p + , [C.XType _ t, x2] <- xs + , isVoidT t + -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2 + return $ blocks + |> Block label + (instrs >< (instrs2 |> (annotNil $ IReturn Nothing))) + + -- Return a value. + -- We must be at the top-level of the function. + C.XApp{} + | BodyTop <- context + , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + , A.PrimControl A.PrimControlReturn <- p + , [C.XType _ t, x] <- xs + -> do let t' = convertType pp kenv t + vDst <- newUniqueVar t' + is <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x + return $ blocks + |> Block label + (instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst))))) + + -- Fail and abort the program. + -- Allow this inside an expression as well as from the top level. + C.XApp{} + | Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + , A.PrimControl A.PrimControlFail <- p + , [C.XType _ _tResult] <- xs + -> let iFail = ICall Nothing CallTypeStd Nothing + TVoid (NameGlobal "abort") [] [] + + iSet = case context of + BodyTop -> INop + BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst)) + + block = Block label + $ instrs |> annotNil iSet + |> annotNil iFail + |> annotNil IUnreachable + + + in return $ blocks |> block + + + -- Calls ----------------------------------------- + -- Tailcall a function. + -- We must be at the top-level of the function. + C.XApp{} + | Just (A.NamePrimOp p, args) <- takeXPrimApps xx + , A.PrimCall (A.PrimCallTail arity) <- p + , _tsArgs <- take arity args + , C.XType _ tResult : xFunTys : xsArgs <- drop arity args + , Just (xFun, _xsTys) <- takeXApps xFunTys + , Just (Var nFun _) <- takeGlobalV pp mm kenv tenv xFun + , Just xsArgs' <- sequence $ map (mconvAtom pp kenv tenv) xsArgs + -> if isVoidT tResult + -- Tailcalled function returns void. + then do return $ blocks + |> (Block label $ instrs + |> (annotNil $ ICall Nothing CallTypeTail Nothing + (convertType pp kenv tResult) nFun xsArgs' []) + |> (annotNil $ IReturn Nothing)) + + -- Tailcalled function returns an actual value. + else do let tResult' = convertType pp kenv tResult + vDst <- newUniqueVar tResult' + return $ blocks + |> (Block label $ instrs + |> (annotNil $ ICall (Just vDst) CallTypeTail Nothing + (convertType pp kenv tResult) nFun xsArgs' []) + |> (annotNil $ IReturn (Just (XVar vDst)))) + + + -- Assignment ------------------------------------ + + -- A statement of type void does not produce a value. + C.XLet _ (C.LLet (C.BNone t) x1) x2 + | isVoidT t + -> do instrs' <- convExpM ExpTop pp kenv tenv mdsup x1 + convBodyM context kenv tenv mdsup blocks label + (instrs >< instrs') x2 + + -- A non-void let-expression. + -- In C we can just drop a computed value on the floor, + -- but the LLVM compiler needs an explicit name for it. + -- Add the required name then call ourselves again. + C.XLet a (C.LLet (C.BNone t) x1) x2 + | not $ isVoidT t + -> do + n <- newUnique + let b = C.BName (A.NameVar ("_dummy" ++ show n)) t + + convBodyM context kenv tenv mdsup blocks label instrs + (C.XLet a (C.LLet b x1) x2) + + -- Variable assigment from a case-expression. + C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) + (C.XCase _ xScrut alts)) + x2 + -> do + let t' = convertType pp kenv t + + -- Assign result of case to this variable. + let n' = A.sanitizeName n + let vCont = Var (NameLocal n') t' + + -- Label to jump to continue evaluating 'x1' + lCont <- newUniqueLabel "cont" + + let context' = BodyNest vCont lCont + blocksCase <- convCaseM context' pp kenv tenv mdsup + label instrs xScrut alts + + let tenv' = Env.extend b tenv + convBodyM context kenv tenv' mdsup + (blocks >< blocksCase) + lCont + Seq.empty + x2 + + -- Variable assignment from an non-case expression. + C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) x1) x2 + -> do let tenv' = Env.extend b tenv + let n' = A.sanitizeName n + + let t' = convertType pp kenv t + let dst = Var (NameLocal n') t' + instrs' <- convExpM (ExpAssign dst) pp kenv tenv mdsup x1 + convBodyM context kenv tenv' mdsup blocks label (instrs >< instrs') x2 + + + -- Letregions ------------------------------------ + C.XLet _ (C.LPrivate b _mt _) x2 + -> do let kenv' = Env.extends b kenv + convBodyM context kenv' tenv mdsup blocks label instrs x2 + + -- Case ------------------------------------------ + C.XCase _ xScrut alts + -> do blocks' <- convCaseM context pp kenv tenv mdsup + label instrs xScrut alts + + return $ blocks >< blocks' + + -- Cast ------------------------------------------- + C.XCast _ _ x + -> convBodyM context kenv tenv mdsup blocks label instrs x + + _ + | BodyNest vDst label' <- context + -> do instrs' <- convExpM (ExpAssign vDst) pp kenv tenv mdsup xx + return $ blocks >< Seq.singleton (Block label + (instrs >< (instrs' |> (annotNil $ IBranch label')))) + + | otherwise + -> die $ renderIndent + $ text "Invalid body statement " + <$> ppr xx + + +-- Exp -------------------------------------------------------------------------------------------- +-- | What context we're doing this conversion in. +data ExpContext + -- | Conversion at the top-level of the function. + -- We don't have a variable to assign the result to, + -- so this must be a statement that transfers control + = ExpTop + + -- | Conversion in a context that expects a value. + -- We evaluate the expression and assign the result to this variable. + | ExpAssign Var + deriving Show + + +-- | Take any assignable variable from an `ExpContext`. +varOfExpContext :: ExpContext -> Maybe Var +varOfExpContext xc + = case xc of + ExpTop -> Nothing + ExpAssign var -> Just var + + +-- | Convert a simple Core expression to LLVM instructions. +-- +-- This only works for variables, literals, and full applications of +-- primitive operators. The client should ensure the program is in this form +-- before converting it. The result is just a sequence of instructions, + -- so there are no new labels to jump to. +convExpM + :: ExpContext + -> Platform + -> KindEnv A.Name + -> TypeEnv A.Name + -> MDSuper + -> C.Exp () A.Name -- ^ Expression to convert. + -> LlvmM (Seq AnnotInstr) + +convExpM context pp kenv tenv mdsup xx + = do mm <- gets llvmStateModule + case xx of + C.XVar _ u@(C.UName (A.NameVar n)) + | Just t <- Env.lookup u tenv + , ExpAssign vDst <- context + -> do let n' = A.sanitizeName n + let t' = convertType pp kenv t + return $ Seq.singleton $ annotNil + $ ISet vDst (XVar (Var (NameLocal n') t')) + + C.XCon _ dc + | Just n <- takeNameOfDaCon dc + , ExpAssign vDst <- context + -> case n of + A.NameLitNat i + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (tNat pp) i)) + + A.NameLitInt i + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (tInt pp) i)) + + A.NameLitWord w bits + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w)) + + _ -> die "Invalid literal" + + C.XApp{} + -- Call to primop. + | Just (C.XVar _ (C.UPrim (A.NamePrimOp p) tPrim), args) <- takeXApps xx + -> convPrimCallM pp kenv tenv mdsup + (varOfExpContext context) + p tPrim args + + -- Call to top-level super. + | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx + , Just (Var nFun _) <- takeGlobalV pp mm kenv tenv xFun + , Just xsArgs_value' <- sequence $ map (mconvAtom pp kenv tenv) + $ eraseTypeWitArgs xsArgs + , Just tSuper <- Env.lookup u tenv + -> let (_, tResult) = convertSuperType pp kenv tSuper + in return $ Seq.singleton $ annotNil + $ ICall (varOfExpContext context) CallTypeStd Nothing + tResult nFun xsArgs_value' [] + + C.XCast _ _ x + -> convExpM context pp kenv tenv mdsup x + + _ -> die $ "Invalid expression " ++ show xx + + +-- Case ------------------------------------------------------------------------------------------- +convCaseM + :: BodyContext + -> Platform + -> KindEnv A.Name + -> TypeEnv A.Name + -> MDSuper + -> Label -- label of current block + -> Seq AnnotInstr -- intrs to prepend to initial block. + -> C.Exp () A.Name + -> [C.Alt () A.Name] + -> LlvmM (Seq Block) + +convCaseM context pp kenv tenv mdsup label instrs xScrut alts + | Just vScrut'@Var{} <- takeLocalV pp kenv tenv xScrut + = do + -- Convert all the alternatives. + -- If we're in a nested context we'll also get a block to join the + -- results of each alternative. + (alts', blocksJoin) + <- convAlts context pp kenv tenv mdsup alts + + -- Build the switch --------------- + -- Determine what default alternative to use for the instruction. + (lDefault, blocksDefault) + <- case last alts' of + AltDefault l bs -> return (l, bs) + AltCase _ l bs -> return (l, bs) + + -- Alts that aren't the default. + let Just altsTable = takeInit alts' + + -- Build the jump table of non-default alts. + let table = mapMaybe takeAltCase altsTable + let blocksTable = join $ fmap altResultBlocks $ Seq.fromList altsTable + + let switchBlock + = Block label + $ instrs + |> (annotNil $ ISwitch (XVar vScrut') lDefault table) + + return $ switchBlock + <| (blocksTable >< blocksDefault >< blocksJoin) + +convCaseM _ _ _ _ _ _ _ _ _ + = die "Invalid case expression" + + +-- Alts ------------------------------------------------------------------------------------------- +convAlts + :: BodyContext + -> Platform + -> KindEnv A.Name + -> TypeEnv A.Name + -> MDSuper + -> [C.Alt () A.Name] + -> LlvmM ([AltResult], Seq Block) + +-- Alternatives are at top level. +convAlts BodyTop + _pp kenv tenv mdsup alts + = do + alts' <- mapM (convAltM BodyTop kenv tenv mdsup) alts + return (alts', Seq.empty) + + +-- If we're doing a branch inside a let-binding we need to add a join +-- point to collect the results from each altenative before continuing +-- on to evaluate the rest. +convAlts (BodyNest vDst lCont) + _pp kenv tenv mdsup alts + = do + let tDst' = typeOfVar vDst + + -- Label of the block that does the join. + lJoin <- newUniqueLabel "join" + + -- Convert all the alternatives, + -- assiging their results into separate vars. + (vDstAlts, alts'@(_:_)) + <- liftM unzip + $ mapM (\alt -> do + vDst' <- newUniqueNamedVar "alt" tDst' + alt' <- convAltM (BodyNest vDst' lJoin) kenv tenv mdsup alt + return (vDst', alt')) + $ alts + + -- A block to join the result from each alternative. + -- Trying to keep track of which block a variable is defined in is + -- too hard when we have nested join points. + -- Instead, we set the label here to 'unknown' and fix this up in the + -- Clean transform. + let blockJoin + = Block lJoin + $ Seq.fromList $ map annotNil + [ IPhi vDst [ (XVar vDstAlt, Label "unknown") + | vDstAlt <- vDstAlts ] + , IBranch lCont ] + + return (alts', Seq.singleton blockJoin) + + +-- Alt -------------------------------------------------------------------------------------------- +-- | Holds the result of converting an alternative. +data AltResult + = AltDefault Label (Seq Block) + | AltCase Lit Label (Seq Block) + + +-- | Convert a case alternative to LLVM. +-- +-- This only works for zero-arity constructors. +-- The client should extrac the fields of algebraic data objects manually. +convAltM + :: BodyContext -- ^ Context we're converting in. + -> KindEnv A.Name -- ^ Kind environment. + -> TypeEnv A.Name -- ^ Type environment. + -> MDSuper -- ^ Meta-data for the enclosing super. + -> C.Alt () A.Name -- ^ Alternative to convert. + -> LlvmM AltResult + +convAltM context kenv tenv mdsup aa + = do pp <- gets llvmStatePlatform + case aa of + C.AAlt C.PDefault x + -> do label <- newUniqueLabel "default" + blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x + return $ AltDefault label blocks + + C.AAlt (C.PData dc []) x + | Just n <- takeNameOfDaCon dc + , Just lit <- convPatName pp n + -> do label <- newUniqueLabel "alt" + blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x + return $ AltCase lit label blocks + + _ -> die "Invalid alternative" + + +-- | Convert a constructor name from a pattern to a LLVM literal. +-- +-- Only integral-ish types can be used as patterns, for others +-- such as Floats we rely on the Lite transform to have expanded +-- cases on float literals into a sequence of boolean checks. +convPatName :: Platform -> A.Name -> Maybe Lit +convPatName pp name + = case name of + A.NameLitBool True -> Just $ LitInt (TInt 1) 1 + A.NameLitBool False -> Just $ LitInt (TInt 1) 0 + + A.NameLitNat i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.NameLitInt i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.NameLitWord i bits + | elem bits [8, 16, 32, 64] + -> Just $ LitInt (TInt $ fromIntegral bits) i + + A.NameLitTag i -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i + + _ -> Nothing + + +-- | Take the blocks from an `AltResult`. +altResultBlocks :: AltResult -> Seq Block +altResultBlocks aa + = case aa of + AltDefault _ blocks -> blocks + AltCase _ _ blocks -> blocks + + +-- | Take the `Lit` and `Label` from an `AltResult` +takeAltCase :: AltResult -> Maybe (Lit, Label) +takeAltCase (AltCase lit label _) = Just (lit, label) +takeAltCase _ = Nothing + diff --git a/DDC/Core/Llvm/Convert/Prim.hs b/DDC/Core/Llvm/Convert/Prim.hs --- a/DDC/Core/Llvm/Convert/Prim.hs +++ b/DDC/Core/Llvm/Convert/Prim.hs @@ -19,8 +19,8 @@ -- Prim call ------------------------------------------------------------------ -- | Convert a primitive call to LLVM. -convPrimCallM - :: Show a +convPrimCallM + :: Show a => Platform -> KindEnv A.Name -> TypeEnv A.Name @@ -35,7 +35,7 @@ = case p of -- Binary operations ---------- A.PrimArith op - | C.XType t : args <- xs + | C.XType _ t : args <- xs , Just [x1', x2'] <- mconvAtoms pp kenv tenv args , Just dst <- mdst -> let result @@ -54,7 +54,7 @@ -- Cast primops --------------- A.PrimCast A.PrimCastPromote - | [C.XType tDst, C.XType tSrc, xSrc] <- xs + | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs , Just xSrc' <- mconvAtom pp kenv tenv xSrc , Just vDst <- mdst , minstr <- convPrimPromote pp kenv tDst vDst tSrc xSrc' @@ -66,7 +66,7 @@ , text " to type: " <> ppr tDst] A.PrimCast A.PrimCastTruncate - | [C.XType tDst, C.XType tSrc, xSrc] <- xs + | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs , Just xSrc' <- mconvAtom pp kenv tenv xSrc , Just vDst <- mdst , minstr <- convPrimTruncate pp kenv tDst vDst tSrc xSrc' @@ -78,14 +78,14 @@ , text " to type: " <> ppr tDst ] -- Store primops -------------- - A.PrimStore A.PrimStoreSize - | [C.XType t] <- xs + A.PrimStore A.PrimStoreSize + | [C.XType _ t] <- xs , Just vDst <- mdst -> let t' = convertType pp kenv t size = case t' of - TPointer _ -> platformAddrBytes pp + TPointer _ -> platformAddrBytes pp TInt bits - | bits `mod` 8 == 0 -> bits `div` 8 + | bits `rem` 8 == 0 -> bits `div` 8 _ -> sorry -- Bool# is only 1 bit long. @@ -99,13 +99,13 @@ A.PrimStore A.PrimStoreSize2 - | [C.XType t] <- xs + | [C.XType _ t] <- xs , Just vDst <- mdst -> let t' = convertType pp kenv t size = case t' of - TPointer _ -> platformAddrBytes pp - TInt bits - | bits `mod` 8 == 0 -> bits `div` 8 + TPointer _ -> platformAddrBytes pp + TInt bits + | bits `rem` 8 == 0 -> bits `div` 8 _ -> sorry size2 = truncate $ (log (fromIntegral size) / log 2 :: Double) @@ -124,18 +124,18 @@ | Just [xBytes'] <- mconvAtoms pp kenv tenv xs -> do vAddr <- newUniqueNamedVar "addr" (tAddr pp) vMax <- newUniqueNamedVar "max" (tAddr pp) - let vTopPtr = Var (NameGlobal "_DDC_Runtime_heapTop") (TPointer (tAddr pp)) - let vMaxPtr = Var (NameGlobal "_DDC_Runtime_heapMax") (TPointer (tAddr pp)) + let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) + let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp)) return $ Seq.fromList $ map annotNil [ ICall (Just vAddr) CallTypeStd Nothing - (tAddr pp) (NameGlobal "malloc") - [xBytes'] [] + (tAddr pp) (NameGlobal "malloc") + [xBytes'] [] -- Store the top-of-heap pointer , IStore (XVar vTopPtr) (XVar vAddr) - -- Store the maximum heap pointer + -- Store the maximum heap pointer , IOp vMax OpAdd (XVar vAddr) xBytes' , IStore (XVar vMaxPtr) (XVar vMax) ] @@ -146,8 +146,8 @@ -> do let vTop = Var (bumpName nDst "top") (tAddr pp) let vMin = Var (bumpName nDst "min") (tAddr pp) let vMax = Var (bumpName nDst "max") (tAddr pp) - let vTopPtr = Var (NameGlobal "_DDC_Runtime_heapTop") (TPointer (tAddr pp)) - let vMaxPtr = Var (NameGlobal "_DDC_Runtime_heapMax") (TPointer (tAddr pp)) + let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) + let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp)) return $ Seq.fromList $ map annotNil [ ILoad vTop (XVar vTopPtr) @@ -159,15 +159,15 @@ | Just vDst@(Var nDst _) <- mdst , Just [xBytes'] <- mconvAtoms pp kenv tenv xs -> do let vBump = Var (bumpName nDst "bump") (tAddr pp) - let vTopPtr = Var (NameGlobal "_DDC_Runtime_heapTop") (TPointer (tAddr pp)) + let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) return $ Seq.fromList $ map annotNil - [ ILoad vDst (XVar vTopPtr) + [ ILoad vDst (XVar vTopPtr) , IOp vBump OpAdd (XVar vDst) xBytes' , IStore (XVar vTopPtr) (XVar vBump)] A.PrimStore A.PrimStoreRead - | C.XType _t : args <- xs + | C.XType{} : args <- xs , Just [xAddr', xOffset'] <- mconvAtoms pp kenv tenv args , Just vDst@(Var nDst tDst) <- mdst -> let vOff = Var (bumpName nDst "off") (tAddr pp) @@ -179,8 +179,8 @@ , ILoad vDst (XVar vPtr) ] A.PrimStore A.PrimStoreWrite - | C.XType _t : args <- xs - , Just [xAddr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args + | C.XType{} : args <- xs + , Just [xAddr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args -> do vOff <- newUniqueNamedVar "off" (tAddr pp) vPtr <- newUniqueNamedVar "ptr" (tPtr $ typeOfExp xVal') return $ Seq.fromList @@ -202,7 +202,7 @@ $ IOp vDst OpSub xAddr' xOffset' A.PrimStore A.PrimStorePeek - | C.XType _r : C.XType tDst : args <- xs + | C.XType{} : C.XType _ tDst : args <- xs , Just [xPtr', xOffset'] <- mconvAtoms pp kenv tenv args , Just vDst@(Var nDst _) <- mdst , tDst' <- convertType pp kenv tDst @@ -213,12 +213,12 @@ $ (map annotNil [ IConv vAddr1 ConvPtrtoint xPtr' , IOp vAddr2 OpAdd (XVar vAddr1) xOffset' - , IConv vPtr ConvInttoptr (XVar vAddr2) ]) + , IConv vPtr ConvInttoptr (XVar vAddr2) ]) ++ [(annot kenv mdsup xs ( ILoad vDst (XVar vPtr)))] A.PrimStore A.PrimStorePoke - | C.XType _r : C.XType tDst : args <- xs + | C.XType{} : C.XType _ tDst : args <- xs , Just [xPtr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args , tDst' <- convertType pp kenv tDst -> do vAddr1 <- newUniqueNamedVar "addr1" (tAddr pp) @@ -229,7 +229,7 @@ [ IConv vAddr1 ConvPtrtoint xPtr' , IOp vAddr2 OpAdd (XVar vAddr1) xOffset' , IConv vPtr ConvInttoptr (XVar vAddr2) ]) - ++ [(annot kenv mdsup xs + ++ [(annot kenv mdsup xs ( IStore (XVar vPtr) xVal' ))] A.PrimStore A.PrimStorePlusPtr @@ -257,21 +257,21 @@ , IConv vDst ConvInttoptr (XVar vAddr2) ] A.PrimStore A.PrimStoreMakePtr - | [C.XType _r, C.XType _t, xAddr] <- xs + | [C.XType{}, C.XType{}, xAddr] <- xs , Just xAddr' <- mconvAtom pp kenv tenv xAddr , Just vDst <- mdst -> return $ Seq.singleton $ annotNil $ IConv vDst ConvInttoptr xAddr' A.PrimStore A.PrimStoreTakePtr - | [C.XType _r, C.XType _t, xPtr] <- xs + | [C.XType{}, C.XType{}, xPtr] <- xs , Just xPtr' <- mconvAtom pp kenv tenv xPtr , Just vDst <- mdst -> return $ Seq.singleton $ annotNil $ IConv vDst ConvPtrtoint xPtr' A.PrimStore A.PrimStoreCastPtr - | [C.XType _r, C.XType _tSrc, C.XType _tDst, xPtr] <- xs + | [C.XType{}, C.XType{}, C.XType{}, xPtr] <- xs , Just xPtr' <- mconvAtom pp kenv tenv xPtr , Just vDst <- mdst -> return $ Seq.singleton $ annotNil @@ -294,15 +294,15 @@ convPrimArith2 :: A.PrimArith -> C.Type A.Name -> Maybe Op convPrimArith2 op t = case op of - A.PrimArithAdd + A.PrimArithAdd | isIntegralT t -> Just OpAdd - | isFloatingT t -> Just OpFAdd + | isFloatingT t -> Just OpFAdd - A.PrimArithSub + A.PrimArithSub | isIntegralT t -> Just OpSub | isFloatingT t -> Just OpFSub - A.PrimArithMul + A.PrimArithMul | isIntegralT t -> Just OpMul | isFloatingT t -> Just OpFMul @@ -336,12 +336,12 @@ -- Cast ----------------------------------------------------------------------- --- | Convert a primitive promotion to LLVM, +-- | Convert a primitive promotion to LLVM, -- or `Nothing` for an invalid promotion. -convPrimPromote - :: Platform +convPrimPromote + :: Platform -> KindEnv A.Name - -> C.Type A.Name -> Var + -> C.Type A.Name -> Var -> C.Type A.Name -> Exp -> Maybe Instr @@ -349,19 +349,19 @@ | tSrc' <- convertType pp kenv tSrc , tDst' <- convertType pp kenv tDst , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc - , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst + , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst , A.primCastPromoteIsValid pp tcSrc tcDst = case (tDst', tSrc') of (TInt bitsDst, TInt bitsSrc) - -- Same sized integers - | bitsDst == bitsSrc + -- Same sized integers + | bitsDst == bitsSrc -> Just $ ISet vDst xSrc -- Both Unsigned | isUnsignedT tSrc , isUnsignedT tDst - , bitsDst > bitsSrc + , bitsDst > bitsSrc -> Just $ IConv vDst ConvZext xSrc -- Both Signed @@ -382,10 +382,10 @@ = Nothing --- | Convert a primitive truncation to LLVM, +-- | Convert a primitive truncation to LLVM, -- or `Nothing` for an invalid truncation. convPrimTruncate - :: Platform + :: Platform -> KindEnv A.Name -> C.Type A.Name -> Var -> C.Type A.Name -> Exp @@ -395,21 +395,21 @@ | tSrc' <- convertType pp kenv tSrc , tDst' <- convertType pp kenv tDst , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc - , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst + , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst , A.primCastTruncateIsValid pp tcSrc tcDst = case (tDst', tSrc') of (TInt bitsDst, TInt bitsSrc) -- Same sized integers - | bitsDst == bitsSrc + | bitsDst == bitsSrc -> Just $ ISet vDst xSrc -- Destination is smaller - | bitsDst < bitsSrc + | bitsDst < bitsSrc -> Just $ IConv vDst ConvTrunc xSrc -- Unsigned to Signed, -- destination is larger - | bitsDst > bitsSrc + | bitsDst > bitsSrc , isUnsignedT tSrc , isSignedT tDst -> Just $ IConv vDst ConvZext xSrc diff --git a/DDC/Core/Llvm/Convert/Super.hs b/DDC/Core/Llvm/Convert/Super.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Super.hs @@ -0,0 +1,126 @@ + +module DDC.Core.Llvm.Convert.Super + (convSuperM) +where +import DDC.Core.Llvm.Convert.Exp +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Llvm.Convert.Erase +import DDC.Core.Llvm.LlvmM +import DDC.Llvm.Syntax +import DDC.Core.Salt.Platform +import DDC.Core.Compounds +import DDC.Base.Pretty hiding (align) +import DDC.Type.Env (KindEnv, TypeEnv) +import Control.Monad.State.Strict (gets) +import qualified DDC.Core.Llvm.Metadata.Tbaa as Tbaa +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Convert as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C +import qualified DDC.Type.Env as Env +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Seq + + +-- | Convert a top-level supercombinator to a LLVM function. +-- Region variables are completely stripped out. +convSuperM + :: KindEnv A.Name + -> TypeEnv A.Name + -> C.Bind A.Name -- ^ Bind of the top-level super. + -> C.Exp () A.Name -- ^ Super body. + -> LlvmM (Function, [MDecl]) + +convSuperM kenv tenv bSuper@(C.BName nSuper tSuper) x + | Just (bfsParam, xBody) <- takeXLamFlags x + = do + platform <- gets llvmStatePlatform + mm <- gets llvmStateModule + + let nsExports = Set.fromList $ map fst $ C.moduleExportValues mm + + -- Sanitise the super name so we can use it as a symbol + -- in the object code. + let Just nSuper' = A.seaNameOfSuper + (lookup nSuper (C.moduleImportValues mm)) + (lookup nSuper (C.moduleExportValues mm)) + nSuper + + -- Add parameters to environments. + let bfsParam' = eraseWitBinds bfsParam + let bsParamType = [b | (True, b) <- bfsParam'] + let bsParamValue = [b | (False, b) <- bfsParam'] + + let kenv' = Env.extends bsParamType kenv + let tenv' = Env.extends (bSuper : bsParamValue) tenv + mdsup <- Tbaa.deriveMD (renderPlain nSuper') x + + -- Split off the argument and result types of the super. + let (tsParam, tResult) + = convertSuperType platform kenv tSuper + + -- Make parameter binders. + let align = AlignBytes (platformAlignBytes platform) + + -- Declaration of the super. + let decl + = FunctionDecl + { declName = renderPlain nSuper' + + -- Set internal linkage for non-exported functions so that they + -- they won't conflict with functions of the same name that + -- might be defined in other modules. + , declLinkage = if Set.member nSuper nsExports + then External + else Internal + + -- ISSUE #266: Tailcall optimisation doesn't work for exported functions. + -- Using fast calls for non-exported functions enables the + -- LLVM tailcall optimisation. We can't enable this for exported + -- functions as well because we don't distinguish between DDC + -- generated functions and functions from the C libararies in + -- our import specifications. We need a proper FFI system so that + -- we can get tailcalls for exported functions as well. + , declCallConv = if Set.member nSuper nsExports + then CC_Ccc + else CC_Fastcc + + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = [Param t [] | t <- tsParam] + , declAlign = align } + + -- Convert function body to basic blocks. + label <- newUniqueLabel "entry" + blocks <- convBodyM BodyTop kenv' tenv' mdsup Seq.empty label Seq.empty xBody + + -- Build the function. + return $ ( Function + { funDecl = decl + , funParams = [nameOfParam i b + | i <- [0..] + | b <- bsParamValue] + , funAttrs = [] + , funSection = SectionAuto + , funBlocks = Seq.toList blocks } + , Tbaa.decls mdsup ) + + +convSuperM _ _ _ _ + = die "Invalid super" + + +-- | Take the string name to use for a function parameter. +nameOfParam :: Int -> C.Bind A.Name -> String +nameOfParam i bb + = case bb of + C.BName (A.NameVar n) _ + -> A.sanitizeName n + + C.BNone _ + -> "_arg" ++ show i + + _ -> die $ "Invalid parameter name: " ++ show bb + + diff --git a/DDC/Core/Llvm/Convert/Type.hs b/DDC/Core/Llvm/Convert/Type.hs --- a/DDC/Core/Llvm/Convert/Type.hs +++ b/DDC/Core/Llvm/Convert/Type.hs @@ -28,11 +28,14 @@ import DDC.Type.Env import DDC.Type.Compounds import DDC.Type.Predicates +import DDC.Base.Pretty import DDC.Core.Salt as A import DDC.Core.Salt.Name as A +import DDC.Core.Salt.Convert as A import qualified DDC.Core.Module as C import qualified DDC.Core.Exp as C import qualified DDC.Type.Env as Env +import Control.Monad -- Type ----------------------------------------------------------------------- @@ -115,24 +118,42 @@ importedFunctionDeclOfType :: Platform -> KindEnv Name - -> Linkage - -> C.QualName Name + -> C.ImportSource Name + -> Maybe (C.ExportSource Name) + -> Name -> C.Type Name -> Maybe FunctionDecl -importedFunctionDeclOfType pp kenv linkage (C.QualName _ (NameVar n)) tt +importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt + + | C.ImportSourceModule{} <- isrc + = let Just strName = liftM renderPlain + $ seaNameOfSuper (Just isrc) mesrc nSuper + + (tsArgs, tResult) = convertSuperType pp kenv tt + mkParam t = Param t [] + in Just $ FunctionDecl + { declName = A.sanitizeName strName + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = map mkParam tsArgs + , declAlign = AlignBytes (platformAlignBytes pp) } + + | C.ImportSourceSea strName _ <- isrc = let (tsArgs, tResult) = convertSuperType pp kenv tt mkParam t = Param t [] in Just $ FunctionDecl - { declName = A.sanitizeGlobal n - , declLinkage = linkage + { declName = A.sanitizeName strName + , declLinkage = External , declCallConv = CC_Ccc , declReturnType = tResult , declParamListType = FixedArgs , declParams = map mkParam tsArgs , declAlign = AlignBytes (platformAlignBytes pp) } -importedFunctionDeclOfType _ _ _ _ _ +importedFunctionDeclOfType _ _ _ _ _ _ = Nothing @@ -141,6 +162,9 @@ convTyCon :: Platform -> C.TyCon Name -> Type convTyCon platform tycon = case tycon of + C.TyConSpec C.TcConUnit + -> tObj platform + C.TyConBound (C.UPrim NameObjTyCon _) _ -> tObj platform @@ -165,7 +189,7 @@ _ -> die "Invalid primitive type constructor." - _ -> die "Invalid type constructor." + _ -> die $ "Invalid type constructor '" ++ show tycon ++ "'" -- | Type of Heap objects. diff --git a/DDC/Core/Llvm/LlvmM.hs b/DDC/Core/Llvm/LlvmM.hs --- a/DDC/Core/Llvm/LlvmM.hs +++ b/DDC/Core/Llvm/LlvmM.hs @@ -18,8 +18,10 @@ where import DDC.Core.Salt.Platform import DDC.Llvm.Syntax -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map (Map) +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Module as C +import qualified Data.Map as Map import Control.Monad.State.Strict import DDC.Base.Pretty @@ -48,6 +50,9 @@ -- The current platform. , llvmStatePlatform :: Platform + -- The module being converted. + , llvmStateModule :: C.Module () A.Name + -- Primitives in the global environment. , llvmStatePrimDecls :: Map String FunctionDecl } @@ -55,13 +60,15 @@ -- | Initial LLVM state. llvmStateInit :: Platform + -> C.Module () A.Name -> Map String FunctionDecl -> LlvmState -llvmStateInit platform prims +llvmStateInit platform mm prims = LlvmState { llvmStateUnique = 1 , llvmStatePlatform = platform + , llvmStateModule = mm , llvmStatePrimDecls = prims } diff --git a/DDC/Core/Llvm/Metadata/Graph.hs b/DDC/Core/Llvm/Metadata/Graph.hs --- a/DDC/Core/Llvm/Metadata/Graph.hs +++ b/DDC/Core/Llvm/Metadata/Graph.hs @@ -99,7 +99,7 @@ pivot acc ([vertex]:classes) = refine (vertex:acc) $ classes `splitAllOn` vertex pivot acc ((vertex:vs):classes) = refine (vertex:acc) $ (vs:classes) `splitAllOn` vertex - pivot _ _ = error "impossible!" + pivot _ _ = error "ddc-core-llvm.lexBFS: bogus warning suppression." splitAllOn [] _ = [] splitAllOn (cl:classes) vertex @@ -218,7 +218,7 @@ partitionDG :: Eq a => DG a -> [Tree a] partitionDG (DG (d,g)) = let mkGraph g' nodes = (nodes, fromList [ (x,y) | x <- nodes, y <- nodes, g' x y ]) - in map Tree $ fromMaybe (error "partitionDG: no partition found!") + in map Tree $ fromMaybe (error "ddc-core-llvm.partitionDG: no partition found!") $ find (all $ uncurry isTree) $ map (map (mkGraph g)) $ sortBy (comparing (aliasMeasure g)) diff --git a/DDC/Llvm/Pretty/Exp.hs b/DDC/Llvm/Pretty/Exp.hs --- a/DDC/Llvm/Pretty/Exp.hs +++ b/DDC/Llvm/Pretty/Exp.hs @@ -42,7 +42,7 @@ ppr ll = case ll of LitInt t i -> ppr t <+> integer i - LitFloat{} -> error "ppr[Lit]: floats aren't handled yet" + LitFloat{} -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet" LitNull _ -> text "null" LitUndef _ -> text "undef" @@ -52,7 +52,7 @@ pprPlainL ll = case ll of LitInt _ i -> integer i - LitFloat{} -> error "ppr[Lit]: floats aren't handled yet" + LitFloat{} -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet" LitNull _ -> text "null" LitUndef _ -> text "undef" diff --git a/DDC/Llvm/Syntax/Module.hs b/DDC/Llvm/Syntax/Module.hs --- a/DDC/Llvm/Syntax/Module.hs +++ b/DDC/Llvm/Syntax/Module.hs @@ -122,7 +122,9 @@ typeOfStatic :: Static -> Type typeOfStatic ss = case ss of - StaticComment{} -> error "Can't call getStatType on LMComment!" + StaticComment{} + -> error "ddc-core-llvm.typeOfStatic: can't call getStatType on LMComment!" + StaticLit l -> typeOfLit l StaticUninitType t -> t StaticStr _ t -> t diff --git a/DDC/Llvm/Syntax/Type.hs b/DDC/Llvm/Syntax/Type.hs --- a/DDC/Llvm/Syntax/Type.hs +++ b/DDC/Llvm/Syntax/Type.hs @@ -144,7 +144,7 @@ takeBytesOfType :: Integer -> Type -> Maybe Integer takeBytesOfType bytesPtr tt = case tt of - TInt bits -> Just $ fromIntegral $ div bits 8 + TInt bits -> Just $ div bits 8 TFloat -> Just 4 TDouble -> Just 8 TFloat80 -> Just 10 diff --git a/DDC/Llvm/Transform/Clean.hs b/DDC/Llvm/Transform/Clean.hs --- a/DDC/Llvm/Transform/Clean.hs +++ b/DDC/Llvm/Transform/Clean.hs @@ -6,6 +6,7 @@ (clean) where import DDC.Llvm.Syntax +import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Foldable as Seq @@ -158,7 +159,8 @@ ICall (Just v) ct mcc t n xs ats | defs' <- Map.insert v label defs -> let NameGlobal str = n - Just cc2 = lookupCallConv str mm + cc2 = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str) + $ lookupCallConv str mm cc' = mergeCallConvs mcc cc2 in next binds defs' @@ -167,7 +169,8 @@ ICall Nothing ct mcc t n xs ats -> let NameGlobal str = n - Just cc2 = lookupCallConv str mm + cc2 = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str) + $ lookupCallConv str mm cc' = mergeCallConvs mcc cc2 in next binds defs $ (reAnnot $ ICall Nothing ct (Just cc') t n (map sub xs) ats) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/ddc-core-llvm.cabal b/ddc-core-llvm.cabal --- a/ddc-core-llvm.cabal +++ b/ddc-core-llvm.cabal @@ -1,5 +1,5 @@ Name: ddc-core-llvm -Version: 0.3.2.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,15 +14,15 @@ Library Build-Depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + array >= 0.4 && < 0.6, containers == 0.5.*, - array == 0.4.*, transformers == 0.3.*, mtl == 2.1.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.*, - ddc-core-simpl == 0.3.2.*, - ddc-core-salt == 0.3.2.* + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-simpl == 0.4.1.*, + ddc-core-salt == 0.4.1.* Exposed-modules: DDC.Core.Llvm.Metadata.Graph @@ -42,7 +42,9 @@ Other-modules: DDC.Core.Llvm.Convert.Atom DDC.Core.Llvm.Convert.Erase + DDC.Core.Llvm.Convert.Exp DDC.Core.Llvm.Convert.Prim + DDC.Core.Llvm.Convert.Super DDC.Core.Llvm.Convert.Type DDC.Core.Llvm.LlvmM @@ -68,6 +70,7 @@ -Wall -fno-warn-orphans -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind Extensions: