Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@ollef
ollef committed Sep 4, 2024
1 parent 47d0a4d commit 798df3d
Show file tree
Hide file tree
Showing 9 changed files with 297 additions and 220 deletions.
3 changes: 0 additions & 3 deletions rts/memory.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,9 +60,6 @@ void sixten_copy(
uint32_t pointers,
uint32_t non_pointer_bytes
) {
for (uint32_t i = 0; i < pointers; ++i) {
sixten_increase_reference_count(src.pointers[i]);
}
memcpy(dst.pointers, src.pointers, sizeof(void*) * pointers);
memcpy(dst.non_pointers, src.non_pointers, non_pointer_bytes);
}
Expand Down
2 changes: 1 addition & 1 deletion src/Compiler.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,7 @@ compile assemblyDir saveAssembly outputExecutableFile maybeOptimisationLevel pri
else callProcess clang $ optimisationArgs <> ["-fPIC", "-Wno-override-module", "-o", outputExecutableFile, builtinCFile, memoryCFile] <> llvmFiles

supportedLlvmVersions :: [Int]
supportedLlvmVersions = [17, 16, 15]
supportedLlvmVersions = [18, 17, 16, 15]

-- | llvm-config is not available in current LLVM distribution for windows, so we
-- need use @clang -print-prog-name=clang@ to get the full path of @clang@.
Expand Down
8 changes: 5 additions & 3 deletions src/Low/Pretty.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -103,7 +103,7 @@ prettyLetOperation env = \case
2
( vcat $
(prettyBranch env <$> branches)
<> [ "_" <+> "->" <+> prettyTerm env branch
<> [ "_" <+> "->" <> line <> indent 2 (prettyTerm env branch)
| Just branch <- [defaultBranch]
]
)
Expand Down Expand Up @@ -132,6 +132,8 @@ prettySeqOperation env = \case
"copy" <+> commaSep [prettyOperand env dst, prettyOperand env src, prettyOperand env size]
Syntax.IncreaseReferenceCount operand repr ->
"increase_reference_count" <+> pretty repr <+> prettyOperand env operand
Syntax.IncreaseReferenceCounts operand repr ->
"increase_reference_counts" <+> prettyOperand env repr <+> prettyOperand env operand
Syntax.DecreaseReferenceCount operand repr ->
"decrease_reference_count" <+> pretty repr <+> prettyOperand env operand

Expand Down Expand Up @@ -198,9 +200,9 @@ prettyBranch
-> Doc ann
prettyBranch env = \case
Syntax.ConstructorBranch constr body ->
prettyConstr env constr <+> "->" <> prettyTerm env body
prettyConstr env constr <+> "->" <> line <> indent 2 (prettyTerm env body)
Syntax.LiteralBranch lit body ->
pretty lit <+> "->" <> prettyTerm env body
pretty lit <+> "->" <> line <> indent 2 (prettyTerm env body)

-------------------------------------------------------------------------------

Expand Down
1 change: 1 addition & 0 deletions src/Low/Syntax.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ data SeqOperation v
= Store !(Operand v) !(Operand v) !Representation
| Copy !(Operand v) !(Operand v) !(Operand v)
| IncreaseReferenceCount !(Operand v) !Representation
| IncreaseReferenceCounts !(Operand v) !(Operand v)
| DecreaseReferenceCount !(Operand v) !Representation
deriving (Eq, Show, Generic, Hashable)

Expand Down
130 changes: 73 additions & 57 deletions src/LowToLLVM.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -251,13 +251,13 @@ increaseReferenceCount repr o =
"call void @sixten_increase_reference_count"
<> parens ["i64 " <> varName extractedPointer]

decreaseReferenceCounts :: Operand -> Var -> Assembler ()
decreaseReferenceCounts size reference = do
declareLLVMGlobal "sixten_decrease_reference_counts" "declare void @sixten_decrease_reference_counts(ptr, i32)"
increaseReferenceCounts :: Operand -> Operand -> Assembler ()
increaseReferenceCounts size reference = do
declareLLVMGlobal "sixten_increase_reference_counts" "declare void @sixten_increase_reference_counts(ptr, i32)"
(pointers, _) <- extractSizeParts (PassBy.Value Representation.type_, size)
(pointersPointer, _) <- extractParts (PassBy.Reference, Local reference)
(pointersPointer, _) <- extractParts (PassBy.Reference, reference)
emitInstruction $
"call void @sixten_decrease_reference_counts"
"call void @sixten_increase_reference_counts"
<> parens ["ptr " <> operand pointersPointer, "i32 " <> varName pointers]

decreaseReferenceCount :: Representation -> Operand -> Assembler ()
Expand Down Expand Up @@ -294,6 +294,15 @@ decreaseReferenceCount repr o =
"call void @sixten_decrease_reference_count"
<> parens ["i64 " <> varName extractedPointer]

decreaseReferenceCounts :: Operand -> Var -> Assembler ()
decreaseReferenceCounts size reference = do
declareLLVMGlobal "sixten_decrease_reference_counts" "declare void @sixten_decrease_reference_counts(ptr, i32)"
(pointers, _) <- extractSizeParts (PassBy.Value Representation.type_, size)
(pointersPointer, _) <- extractParts (PassBy.Reference, Local reference)
emitInstruction $
"call void @sixten_decrease_reference_counts"
<> parens ["ptr " <> operand pointersPointer, "i32 " <> varName pointers]

-------------------------------------------------------------------------------

assembleModule :: [(Name.Lowered, Syntax.Definition)] -> M Lazy.ByteString
Expand Down Expand Up @@ -350,8 +359,7 @@ assembleFunction functionName env = \case
let parameters = second fromLocal <$> Index.Seq.toSeq env
entry <- freshVar "entry"
startBlock entry
(result, stack) <- assembleTerm env Nothing passReturnBy term
mapM_ restoreStack stack
result <- assembleTerm env Nothing passReturnBy term
endBlock case passReturnBy of
PassBy.Value Representation.Empty -> "ret " <> llvmReturnType passReturnBy
_ -> "ret " <> llvmReturnType passReturnBy <> " " <> operand result
Expand Down Expand Up @@ -406,23 +414,27 @@ assembleTerm
-> Maybe Name
-> PassBy
-> Syntax.Term v
-> Assembler (Operand, Maybe StackAllocation)
-> Assembler Operand
assembleTerm env nameSuggestion passBy = \case
Syntax.Operand o -> do
(_, o') <- assembleOperand env o
pure (o', Nothing)
Syntax.Let passLetBy name term body -> do
(termResult, termStack) <- assembleTerm env (Just name) passLetBy term
(bodyResult, bodyStack) <- assembleTerm (env Index.Seq.:> (passLetBy, termResult)) nameSuggestion passBy body
mapM_ restoreStack termStack
mapM_ restoreStack bodyStack
pure (bodyResult, Nothing)
Syntax.Seq term1 term2 -> do
(_, stack1) <- assembleTerm env Nothing (PassBy.Value Representation.Empty) term1
(result, stack2) <- assembleTerm env nameSuggestion passBy term2
mapM_ restoreStack stack1
mapM_ restoreStack stack2
pure (result, Nothing)
pure o'
Syntax.Let passLetBy name operation body -> do
(operationResult, operationStack) <- assembleLetOperation env (Just name) passLetBy operation
bodyResult <- assembleTerm (env Index.Seq.:> (passLetBy, operationResult)) nameSuggestion passBy body
mapM_ restoreStack operationStack
pure bodyResult
Syntax.Seq operation body -> do
assembleSeqOperation env operation
assembleTerm env nameSuggestion passBy body

assembleLetOperation
:: Environment v
-> Maybe Name
-> PassBy
-> Syntax.LetOperation v
-> Assembler (Operand, Maybe StackAllocation)
assembleLetOperation env nameSuggestion passBy = \case
Syntax.Case scrutinee branches defaultBranch -> do
scrutinee' <- assembleOperand env scrutinee
branchLabels <- forM branches \case
Expand Down Expand Up @@ -452,15 +464,13 @@ assembleTerm env nameSuggestion passBy = \case
]
branchResults <- forM (zip branchLabels branches) \((_, branchLabel), branch) -> do
startBlock branchLabel
(result, stack) <- assembleTerm env nameSuggestion passBy $ Syntax.branchTerm branch
mapM_ restoreStack stack
result <- assembleTerm env nameSuggestion passBy $ Syntax.branchTerm branch
afterBranchLabel <- gets (.basicBlockName)
endBlock $ "br label " <> varName afterSwitchLabel
pure (afterBranchLabel, result)
startBlock defaultLabel
maybeDefaultResult <- forM defaultBranch \branch -> do
(result, stack) <- assembleTerm env nameSuggestion passBy branch
mapM_ restoreStack stack
result <- assembleTerm env nameSuggestion passBy branch
afterBranchLabel <- gets (.basicBlockName)
pure (afterBranchLabel, result)
let defaultResult = fromMaybe (defaultLabel, Constant "undef") maybeDefaultResult
Expand Down Expand Up @@ -601,36 +611,6 @@ assembleTerm env nameSuggestion passBy = \case
"ptr"
updatedNonPointerPointer
pure (Local result, Nothing)
Syntax.Copy dst src size -> do
dst' <- assembleOperand env dst
src' <- assembleOperand env src
size' <- assembleOperand env size
(pointers, nonPointerBytes) <- extractSizeParts size'
declareLLVMGlobal "sixten_copy" "declare void @sixten_copy({ptr, ptr}, {ptr, ptr}, i32, i32)"
emitInstruction $
"call void @sixten_copy"
<> parens
[ typedOperand dst'
, typedOperand src'
, "i32 " <> varName pointers
, "i32 " <> varName nonPointerBytes
]
pure (Constant "undef", Nothing)
Syntax.Store dst src repr -> do
dst' <- assembleOperand env dst
src' <- assembleOperand env src
(dstPointerPointer, dstNonPointerPointer) <- extractParts dst'
case (pointerType repr.pointers, nonPointerType repr.nonPointerBytes) of
(Nothing, Nothing) -> pure ()
(Just _, Nothing) ->
emitInstruction $ "store " <> typedOperand src' <> ", ptr " <> operand dstPointerPointer
(Nothing, Just _) ->
emitInstruction $ "store " <> typedOperand src' <> ", ptr " <> operand dstNonPointerPointer
(Just p, Just np) -> do
(pointerSrc, nonPointerSrc) <- extractParts src'
emitInstruction $ "store " <> p <> " " <> operand pointerSrc <> ", ptr " <> operand dstPointerPointer
emitInstruction $ "store " <> np <> " " <> operand nonPointerSrc <> ", ptr " <> operand dstNonPointerPointer
pure (Constant "undef", Nothing)
Syntax.Load src repr -> do
src' <- assembleOperand env src
(srcPointerPointer, srcNonPointerPointer) <- extractParts src'
Expand All @@ -653,14 +633,50 @@ assembleTerm env nameSuggestion passBy = \case
pure $ Local result

pure (result, Nothing)

assembleSeqOperation
:: Environment v
-> Syntax.SeqOperation v
-> Assembler ()
assembleSeqOperation env = \case
Syntax.Store dst src repr -> do
dst' <- assembleOperand env dst
src' <- assembleOperand env src
(dstPointerPointer, dstNonPointerPointer) <- extractParts dst'
case (pointerType repr.pointers, nonPointerType repr.nonPointerBytes) of
(Nothing, Nothing) -> pure ()
(Just _, Nothing) ->
emitInstruction $ "store " <> typedOperand src' <> ", ptr " <> operand dstPointerPointer
(Nothing, Just _) ->
emitInstruction $ "store " <> typedOperand src' <> ", ptr " <> operand dstNonPointerPointer
(Just p, Just np) -> do
(pointerSrc, nonPointerSrc) <- extractParts src'
emitInstruction $ "store " <> p <> " " <> operand pointerSrc <> ", ptr " <> operand dstPointerPointer
emitInstruction $ "store " <> np <> " " <> operand nonPointerSrc <> ", ptr " <> operand dstNonPointerPointer
Syntax.Copy dst src size -> do
dst' <- assembleOperand env dst
src' <- assembleOperand env src
size' <- assembleOperand env size
(pointers, nonPointerBytes) <- extractSizeParts size'
declareLLVMGlobal "sixten_copy" "declare void @sixten_copy({ptr, ptr}, {ptr, ptr}, i32, i32)"
emitInstruction $
"call void @sixten_copy"
<> parens
[ typedOperand dst'
, typedOperand src'
, "i32 " <> varName pointers
, "i32 " <> varName nonPointerBytes
]
Syntax.IncreaseReferenceCount val repr -> do
(_, val') <- assembleOperand env val
increaseReferenceCount repr val'
pure (Constant "undef", Nothing)
Syntax.IncreaseReferenceCounts val repr -> do
(_, val') <- assembleOperand env val
(_, repr') <- assembleOperand env repr
increaseReferenceCounts repr' val'
Syntax.DecreaseReferenceCount val repr -> do
(_, val') <- assembleOperand env val
decreaseReferenceCount repr val'
pure (Constant "undef", Nothing)

assembleOperand :: Environment v -> Syntax.Operand v -> Assembler (PassBy, Operand)
assembleOperand env = \case
Expand Down
86 changes: 80 additions & 6 deletions src/Lower.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -514,11 +514,64 @@ generateTerm context nameSuggestion indices term typeValue = case term of
Value Representation.type_
CC.Syntax.Closure {} -> panic "TODO closure"
CC.Syntax.ApplyClosure {} -> panic "TODO closure"
CC.Syntax.Case _scrutinee type_ _branches _maybeDefault -> do
size <- generateTypeSize context indices type_
dst <- letReference "case_dst" $ StackAllocate size
_ <- storeTerm context indices dst term
pure $ OperandStorage dst $ Reference size
CC.Syntax.Case scrutinee type_ branches maybeDefault -> do
passTypeBy <- lift $ CC.Representation.passTypeBy (CC.toEnvironment context) typeValue
case passTypeBy of
PassBy.Reference -> do
size <- generateTypeSize context indices type_
dst <- letReference "case_dst" $ StackAllocate size
_ <- storeTerm context indices dst term
pure $ OperandStorage dst $ Reference size
PassBy.Value repr -> do
scrutinee' <- generateTermWithoutType context indices scrutinee
branches' <- CC.Representation.compileBranches branches
result <- case branches' of
CC.Representation.TaggedConstructorBranches Unboxed constrBranches -> do
scrutineeRef <- forceReference Nothing scrutinee'
tag <- letLoad "tag" scrutineeRef Representation.int
let payload name = letOffset name scrutineeRef $ Representation Representation.int
constrBranches' <- forM constrBranches \(constr, constrBranch) ->
map (ConstructorBranch constr) $
lift $
collect $
generateBranch context indices payload repr typeValue constrBranch
defaultBranch <-
forM maybeDefault $ \branch ->
lift $ collect $ do
branch' <- generateTerm context Nothing indices branch typeValue
forceValue repr branch'
letValue repr "result" $ Case tag constrBranches' defaultBranch
CC.Representation.TaggedConstructorBranches Boxed constrBranches -> do
scrutineeValue <- forceValue Representation.pointer scrutinee'
tag <- letValue Representation.int "tag" $ PointerTag scrutineeValue
let payload name = letReference name $ HeapPayload scrutineeValue
constrBranches' <- forM constrBranches \(constr, constrBranch) ->
map (ConstructorBranch constr) $ lift $ collect do
generateBranch context indices payload repr typeValue constrBranch
defaultBranch <- forM maybeDefault $ \branch -> lift $ collect $ do
branch' <- generateTerm context Nothing indices branch typeValue
forceValue repr branch'
letValue repr "result" $ Case tag constrBranches' defaultBranch
CC.Representation.UntaggedConstructorBranch Unboxed constrBranch -> do
let payload name = forceReference (Just name) scrutinee'
generateBranch context indices payload repr typeValue constrBranch
CC.Representation.UntaggedConstructorBranch Boxed constrBranch -> do
scrutineeValue <- forceValue Representation.pointer scrutinee'
let payload name = letReference name $ HeapPayload scrutineeValue
generateBranch context indices payload repr typeValue constrBranch
CC.Representation.LiteralBranches litBranches -> do
scrutineeValue <- forceValue Representation.int scrutinee'
litBranches' <- forM (OrderedHashMap.toList litBranches) \(lit, litBranch) ->
map (LiteralBranch lit) $
lift $
collect $ do
litBranch' <- generateTerm context Nothing indices litBranch typeValue
forceValue repr litBranch'
defaultBranch <- forM maybeDefault $ \branch -> lift $ collect $ do
branch' <- generateTerm context Nothing indices branch typeValue
forceValue repr branch'
letValue repr "result" $ Case scrutineeValue litBranches' defaultBranch
pure $ OperandStorage result $ Value repr

storeCall
:: CC.Context v
Expand All @@ -545,7 +598,28 @@ storeCall context indices dst function args passArgsBy passReturnBy = do
callResult <- letCall passReturnBy "call_result" function callArgs
storeOperand dst $ OperandStorage callResult $ Value repr
PassBy.Reference ->
letCall passReturnBy "call_result_size" function (dst : callArgs)
letCall (PassBy.Value Representation.type_) "call_result_size" function (dst : callArgs)

generateBranch
:: CC.Context v
-> Index.Seq v OperandStorage
-> (Name -> Collect Operand)
-> Representation
-> CC.Domain.Type
-> Telescope Name CC.Syntax.Type CC.Syntax.Term v
-> Collect Operand
generateBranch context indices mpayload repr typeValue = \case
Telescope.Empty term -> do
term' <- generateTerm context Nothing indices term typeValue
forceValue repr term'
Telescope.Extend name type_ _plicity tele -> do
payload <- mpayload name
size <- generateTypeSize context indices type_
fieldTypeValue <- lift $ CC.Domain.Lazy <$> lazy (Evaluation.evaluate (CC.toEnvironment context) type_)
(context', _) <- lift $ CC.extend context fieldTypeValue
let indices' = indices Index.Seq.:> OperandStorage payload (Reference size)
let payload' name' = letOffset name' payload size
generateBranch context' indices' payload' repr typeValue tele

storeBranch
:: CC.Context v
Expand Down
Loading

0 comments on commit 798df3d

Please sign in to comment.