ddc-core-llvm 0.3.2.1 → 0.4.1.1
raw patch · 14 files changed
+812/−731 lines, 14 filesdep ~arraydep ~basedep ~ddc-base
Dependency ranges changed: array, base, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl
Files
- DDC/Core/Llvm/Convert.hs +39/−617
- DDC/Core/Llvm/Convert/Atom.hs +29/−24
- DDC/Core/Llvm/Convert/Exp.hs +503/−0
- DDC/Core/Llvm/Convert/Prim.hs +50/−50
- DDC/Core/Llvm/Convert/Super.hs +126/−0
- DDC/Core/Llvm/Convert/Type.hs +31/−7
- DDC/Core/Llvm/LlvmM.hs +10/−3
- DDC/Core/Llvm/Metadata/Graph.hs +2/−2
- DDC/Llvm/Pretty/Exp.hs +2/−2
- DDC/Llvm/Syntax/Module.hs +3/−1
- DDC/Llvm/Syntax/Type.hs +1/−1
- DDC/Llvm/Transform/Clean.hs +5/−2
- LICENSE +1/−15
- ddc-core-llvm.cabal +10/−7
DDC/Core/Llvm/Convert.hs view
@@ -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
DDC/Core/Llvm/Convert/Atom.hs view
@@ -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
+ DDC/Core/Llvm/Convert/Exp.hs view
@@ -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+
DDC/Core/Llvm/Convert/Prim.hs view
@@ -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
+ DDC/Core/Llvm/Convert/Super.hs view
@@ -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++
DDC/Core/Llvm/Convert/Type.hs view
@@ -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.
DDC/Core/Llvm/LlvmM.hs view
@@ -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 }
DDC/Core/Llvm/Metadata/Graph.hs view
@@ -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))
DDC/Llvm/Pretty/Exp.hs view
@@ -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"
DDC/Llvm/Syntax/Module.hs view
@@ -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
DDC/Llvm/Syntax/Type.hs view
@@ -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
DDC/Llvm/Transform/Clean.hs view
@@ -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)
LICENSE view
@@ -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-
ddc-core-llvm.cabal view
@@ -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: