From 46c6f5b7abad8b1b752f55fb40e68db55937a7ed Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 16 Feb 2023 11:17:45 +0100 Subject: [PATCH] Fixed scoping of function pointers. --- src/Compiler.hs | 17 ++++++++++------ src/LlvmIr.hs | 54 +++++++++++++++++++++++++++++++------------------ 2 files changed, 45 insertions(+), 26 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index e2bf19b..1425a1a 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -13,6 +13,7 @@ import LlvmIr ( LLVMIr (..), LLVMType (..), LLVMValue (..), + Visibility (..), llvmIrToString, ) import TypeChecker (partitionType) @@ -108,7 +109,7 @@ compile (Program prg) = do goDef :: [Bind] -> CompilerState () goDef [] = return () - goDef (Bind id@(name, t) args exp : xs) = do + goDef (Bind (name, t) args exp : xs) = do emit $ UnsafeRaw "\n" emit $ Comment $ show name <> ": " <> show exp emit $ Define (type2LlvmType t_return) name (map (second type2LlvmType) args) @@ -159,14 +160,18 @@ compile (Program prg) = do emitApp t e1 e2 = appEmitter t e1 e2 [] where appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () - appEmitter t e1 e2 stack = do + appEmitter _t e1 e2 stack = do let newStack = e2 : stack case e1 of EApp t' e1' e2' -> appEmitter t' e1' e2' newStack - EId (name, _) -> do + EId id@(name, t') -> do args <- traverse exprToValue newStack vs <- getNewVar - emit $ SetVariable (Ident $ show vs) (Call (type2LlvmType t) name (map (I64,) args)) + funcs <- gets functions + let vis = case Map.lookup id funcs of + Nothing -> Local + Just _ -> Global + emit $ SetVariable (Ident $ show vs) (Call (type2LlvmType t') vis name (map (I64,) args)) x -> do emit . Comment $ "The unspeakable happened: " emit . Comment $ show x @@ -244,7 +249,7 @@ compile (Program prg) = do case Map.lookup id funcs of Just _ -> do vc <- getNewVar - emit $ SetVariable (Ident $ show vc) (Call (type2LlvmType t) name []) + emit $ SetVariable (Ident $ show vc) (Call (type2LlvmType t) Global name []) return $ VIdent (Ident $ show vc, t) Nothing -> return $ VIdent id exprToValue e = do @@ -255,5 +260,5 @@ compile (Program prg) = do type2LlvmType :: Type -> LLVMType type2LlvmType = \case TInt -> I64 - TFun t _ -> type2LlvmType t + TFun t xs -> Function (type2LlvmType t) [type2LlvmType xs] t -> CustomType $ Ident ("\"" ++ show t ++ "\"") diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 4f3d0af..f8a70fe 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -1,10 +1,16 @@ {-# LANGUAGE LambdaCase #-} -module LlvmIr (LLVMType (..), LLVMIr (..), llvmIrToString, LLVMValue (..), LLVMComp (..)) where - -import Data.List (intercalate) -import TypeCheckerIr +module LlvmIr ( + LLVMType (..), + LLVMIr (..), + llvmIrToString, + LLVMValue (..), + LLVMComp (..), + Visibility (..), +) where +import Data.List (intercalate) +import TypeCheckerIr -- | A datatype which represents some basic LLVM types data LLVMType @@ -14,19 +20,21 @@ data LLVMType | I64 | Ptr | Ref LLVMType + | Function LLVMType [LLVMType] | Array Integer LLVMType | CustomType Ident instance Show LLVMType where show :: LLVMType -> String show = \case - I1 -> "i1" - I8 -> "i8" - I32 -> "i32" - I64 -> "i64" - Ptr -> "ptr" - Ref ty -> show ty <> "*" - Array n ty -> concat ["[", show n, " x ", show ty, "]"] + I1 -> "i1" + I8 -> "i8" + I32 -> "i32" + I64 -> "i64" + Ptr -> "ptr" + Ref ty -> show ty <> "*" + Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" + Array n ty -> concat ["[", show n, " x ", show ty, "]"] CustomType (Ident ty) -> ty data LLVMComp @@ -43,8 +51,8 @@ data LLVMComp instance Show LLVMComp where show :: LLVMComp -> String show = \case - LLEq -> "eq" - LLNe -> "ne" + LLEq -> "eq" + LLNe -> "ne" LLUgt -> "ugt" LLUge -> "uge" LLUlt -> "ult" @@ -54,6 +62,12 @@ instance Show LLVMComp where LLSlt -> "slt" LLSle -> "sle" +data Visibility = Local | Global +instance Show Visibility where + show :: Visibility -> String + show Local = "%" + show Global = "@" + {- | Represents a LLVM "value", as in an integer, a register variable, or a string contstant -} @@ -62,9 +76,9 @@ data LLVMValue = VInteger Integer | VIdent Id | VConstant String instance Show LLVMValue where show :: LLVMValue -> String show v = case v of - VInteger i -> show i + VInteger i -> show i VIdent (n, _) -> "%" <> fromIdent n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -85,7 +99,7 @@ data LLVMIr | Br Ident | BrCond LLVMValue Ident Ident | Label Ident - | Call LLVMType Ident Args + | Call LLVMType Visibility Ident Args | Alloca LLVMType | Store LLVMType Ident LLVMType Ident | Bitcast LLVMType Ident LLVMType @@ -103,9 +117,9 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs {- | Converts a LLVM inststruction to a String, allowing for printing etc. @@ -149,9 +163,9 @@ llvmIrToString = go 0 [ "srem ", show t, " ", show v1, ", " , show v2, "\n" ] - (Call t (Ident i) arg) -> + (Call t vis (Ident i) arg) -> concat - [ "call ", show t, " @", i, "(" + [ "call ", show t, " ", show vis, i, "(" , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg , ")\n" ]