Skip to content

Commit

Permalink
Fix lint errors etc
Browse files Browse the repository at this point in the history
  • Loading branch information
@ollef
ollef committed Feb 6, 2024
1 parent aa2ab4c commit f97f12c
Show file tree
Hide file tree
Showing 45 changed files with 512 additions and 521 deletions.
3 changes: 2 additions & 1 deletion src/Assembly/HeapAllocates.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Assembly.HeapAllocates where
Expand All @@ -17,7 +18,7 @@ type HeapAllocates = MaybeT M ()
run :: HeapAllocates -> M Bool
run ha = do
result <- runMaybeT ha
pure $ case result of
pure case result of
Nothing -> True
Just () -> False

Expand Down
148 changes: 74 additions & 74 deletions src/AssemblyToLLVM.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -150,7 +150,7 @@ freshName (Assembly.NameSuggestion nameSuggestion) = do
s
{ usedNames = HashMap.insert bsName (i + 1) usedNames
}
pure $ Name $ if i == 0 then bsName else bsName <> "$" <> ShortByteString.toShort (toUtf8 (show i :: Text))
pure $ Name if i == 0 then bsName else bsName <> "$" <> ShortByteString.toShort (toUtf8 (show i :: Text))

activateLocal :: Assembly.Type -> Assembly.Local -> Assembler Name
activateLocal type_ local@(Assembly.Local _ nameSuggestion) = do
Expand Down Expand Up @@ -203,8 +203,8 @@ assembleModule definitions = do

assembleDefinition :: Name.Lifted -> Assembly.Definition -> ([(Name, Builder)], HashMap Name Builder)
assembleDefinition name@(Name.Lifted _ liftedNameNumber) definition =
second (.usedGlobals)
$ flip
second (.usedGlobals) $
flip
runState
AssemblerState
{ locals = mempty
Expand All @@ -214,77 +214,77 @@ assembleDefinition name@(Name.Lifted _ liftedNameNumber) definition =
, basicBlocks = mempty
, basicBlockName = panic "AssemblyToLLVM: not in a basic block"
}
$ case definition of
Assembly.KnownConstantDefinition type_ (Literal.Integer value) isConstant -> do
let type' = llvmType type_
pure
[
( name'
, globalName name'
<> " = unnamed_addr "
<> linkage
<> (if isConstant then "constant " else "global ")
<> type'
<> " "
<> Builder.integerDec value
)
]
Assembly.ConstantDefinition type_ functionReturnType parameters basicBlock -> do
let type' = llvmType type_
initName = assembleName $ ClosureConvertedToAssembly.initDefinitionName name
parameters' <- mapM (uncurry activateLocal) parameters
assembleBasicBlockReturningResult functionReturnType basicBlock
basicBlocks <- gets (.basicBlocks)
pure
[
( name'
, globalName name' <> " = unnamed_addr " <> linkage <> "global " <> type' <> " undef"
)
,
( initName
, "define private fastcc "
<> llvmReturnType functionReturnType
<> " "
<> globalName initName
<> parens [typedOperand TypedOperand {type_ = pointer, operand = Local p} | p <- parameters']
<> " align "
<> Builder.intDec alignment
<> " {"
<> basicBlocks
<> "\n}"
)
]
Assembly.FunctionDefinition returnType parameters basicBlock -> do
parameters' <- mapM (uncurry activateLocal) parameters
assembleBasicBlockReturningResult returnType basicBlock
basicBlocks <- gets (.basicBlocks)
pure
[
( name'
, "define "
<> linkage
<> "fastcc "
<> llvmReturnType returnType
<> " "
<> globalName (assembleName name)
<> parens
[ separate
" "
( concat
[ [llvmType type_]
, parameterAttributes type_
, [localName parameter]
]
)
| ((type_, _), parameter) <- zip parameters parameters'
]
<> " align "
<> Builder.intDec alignment
<> " {"
<> basicBlocks
<> "\n}"
)
]
case definition of
Assembly.KnownConstantDefinition type_ (Literal.Integer value) isConstant -> do
let type' = llvmType type_
pure
[
( name'
, globalName name'
<> " = unnamed_addr "
<> linkage
<> (if isConstant then "constant " else "global ")
<> type'
<> " "
<> Builder.integerDec value
)
]
Assembly.ConstantDefinition type_ functionReturnType parameters basicBlock -> do
let type' = llvmType type_
initName = assembleName $ ClosureConvertedToAssembly.initDefinitionName name
parameters' <- mapM (uncurry activateLocal) parameters
assembleBasicBlockReturningResult functionReturnType basicBlock
basicBlocks <- gets (.basicBlocks)
pure
[
( name'
, globalName name' <> " = unnamed_addr " <> linkage <> "global " <> type' <> " undef"
)
,
( initName
, "define private fastcc "
<> llvmReturnType functionReturnType
<> " "
<> globalName initName
<> parens [typedOperand TypedOperand {type_ = pointer, operand = Local p} | p <- parameters']
<> " align "
<> Builder.intDec alignment
<> " {"
<> basicBlocks
<> "\n}"
)
]
Assembly.FunctionDefinition returnType parameters basicBlock -> do
parameters' <- mapM (uncurry activateLocal) parameters
assembleBasicBlockReturningResult returnType basicBlock
basicBlocks <- gets (.basicBlocks)
pure
[
( name'
, "define "
<> linkage
<> "fastcc "
<> llvmReturnType returnType
<> " "
<> globalName (assembleName name)
<> parens
[ separate
" "
( concat
[ [llvmType type_]
, parameterAttributes type_
, [localName parameter]
]
)
| ((type_, _), parameter) <- zip parameters parameters'
]
<> " align "
<> Builder.intDec alignment
<> " {"
<> basicBlocks
<> "\n}"
)
]
where
name' = assembleName name
linkage =
Expand Down
26 changes: 13 additions & 13 deletions src/ClosureConversion.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}

module ClosureConversion where
Expand Down Expand Up @@ -101,20 +102,19 @@ convertGlobal global args = do
applyArgs args $ pure $ ClosureConverted.Global global

functionCase tele =
pure $
case (Telescope.length tele, length args) of
(arity, numArgs)
| arity == numArgs ->
ClosureConverted.Apply global args
| arity < numArgs -> do
let (preArgs, postArgs) =
splitAt arity args
pure case (Telescope.length tele, length args) of
(arity, numArgs)
| arity == numArgs ->
ClosureConverted.Apply global args
| arity < numArgs -> do
let (preArgs, postArgs) =
splitAt arity args

ClosureConverted.ApplyClosure
(ClosureConverted.Apply global preArgs)
postArgs
| otherwise ->
ClosureConverted.Closure global args
ClosureConverted.ApplyClosure
(ClosureConverted.Apply global preArgs)
postArgs
| otherwise ->
ClosureConverted.Closure global args

case definition of
LambdaLifted.TypeDeclaration type_ ->
Expand Down
24 changes: 12 additions & 12 deletions src/ClosureConverted/Evaluation.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -31,15 +32,14 @@ evaluate env term =
let var =
Environment.lookupIndexVar index env

pure $
case Environment.lookupVarValue var env of
Nothing ->
Domain.var var
Just value
| Index.Succ index > Environment.glueableBefore env ->
Domain.Glued (Domain.Var var) mempty value
| otherwise ->
value
pure case Environment.lookupVarValue var env of
Nothing ->
Domain.var var
Just value
| Index.Succ index > Environment.glueableBefore env ->
Domain.Glued (Domain.Var var) mempty value
| otherwise ->
value
Syntax.Global name -> do
maybeDefinition <- fetchVisibleDefinition name
case maybeDefinition of
Expand Down Expand Up @@ -143,7 +143,7 @@ apply env fun args =
appliedValue <- apply env value args
pure $ Domain.Glued hd (spine <> (Domain.App <$> fromList args)) appliedValue
Domain.Lazy lazyValue -> do
lazyValue' <- lazy $ do
lazyValue' <- lazy do
value' <- force lazyValue
apply env value' args
pure $ Domain.Lazy lazyValue'
Expand Down Expand Up @@ -202,7 +202,7 @@ case_ scrutinee branches@(Domain.Branches env branches' defaultBranch) =
casedValue <- case_ value branches
pure $ Domain.Glued hd (spine Tsil.:> Domain.Case branches) casedValue
(Domain.Lazy lazyValue, _) -> do
lazyValue' <- lazy $ do
lazyValue' <- lazy do
value <- force lazyValue
case_ value branches
pure $ Domain.Lazy lazyValue'
Expand All @@ -217,7 +217,7 @@ evaluateClosure (Domain.Closure env body) argument = do
fetchVisibleDefinition :: Name.Lifted -> M (Maybe Syntax.Definition)
fetchVisibleDefinition name = do
result <- try $ fetch $ Query.ClosureConverted name
pure $ case result of
pure case result of
Right def -> Just def
Left (Cyclic (_ :: Some Query)) ->
Nothing
Expand Down
9 changes: 4 additions & 5 deletions src/ClosureConverted/Representation.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
Expand Down Expand Up @@ -161,7 +160,7 @@ unboxedDataRepresentation dataTypeName env (Syntax.ConstructorDefinitions constr
constructorFieldRepresentation env type' mempty
| (_, type_) <- OrderedHashMap.toList constructors
]
pure $ case maybeTags of
pure case maybeTags of
Nothing -> fieldRepresentation
Just _ -> constructorTagRepresentation <> fieldRepresentation
where
Expand Down Expand Up @@ -210,7 +209,7 @@ compileData env dataTypeName (Syntax.ConstructorDefinitions constructors) = do
(\a b -> Syntax.Apply (Name.Lifted Builtin.MaxRepresentationName 0) [a, b])
(Syntax.Global $ Name.Lifted Builtin.EmptyRepresentationName 0)
compiledConstructorFields
pure $ case maybeTags of
pure case maybeTags of
Nothing -> maxFieldSize
Just _ ->
Syntax.Apply
Expand Down Expand Up @@ -301,7 +300,7 @@ compileBranches branches =
pure $ LiteralBranches literalBranches
Syntax.ConstructorBranches typeName constructorBranches -> do
(boxity, maybeTags) <- fetch $ Query.ConstructorRepresentations typeName
pure $ case (maybeTags, OrderedHashMap.toList constructorBranches) of
pure case (maybeTags, OrderedHashMap.toList constructorBranches) of
(Nothing, [(_, constructorBranch)]) -> UntaggedConstructorBranch boxity constructorBranch
(Nothing, _) -> panic "ClosureConverted.Representation.compileBranches: Untagged constructor branch length mismatch"
(Just tags, constructorBranchesList) ->
Expand All @@ -312,7 +311,7 @@ compileBranches branches =
constructorRepresentations :: Name.Qualified -> Task Query (Boxity, Maybe (HashMap Name.Constructor Int))
constructorRepresentations name = do
(definition, _) <- fetch $ Query.ElaboratedDefinition name
pure $ case definition of
pure case definition of
Core.Syntax.DataDefinition boxity tele ->
( boxity
, Telescope.under tele \(Core.Syntax.ConstructorDefinitions constructors) ->
Expand Down
Loading

0 comments on commit f97f12c

Please sign in to comment.