From 4bd869fea2134a99e985e17e088a5589e039f082 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Sat, 30 Dec 2023 01:44:38 +0100 Subject: [PATCH] wip --- builtin/Builtin.vix | 1 + rts/Sixten.Builtin.ll | 69 ++++++-------- src/Builtin.hs | 4 + src/ClosureConverted/Representation.hs | 39 ++++---- src/ClosureConvertedToAssembly.hs | 125 ++++++++----------------- src/Representation.hs | 47 ++-------- 6 files changed, 103 insertions(+), 182 deletions(-) diff --git a/builtin/Builtin.vix b/builtin/Builtin.vix index 5194cbfc..23f2ac0c 100644 --- a/builtin/Builtin.vix +++ b/builtin/Builtin.vix @@ -18,6 +18,7 @@ subInt : Int -> Int -> Int EmptyRepresentation : Type WordRepresentation : Type +PointerRepresentation : Type maxRepresentation : Type -> Type -> Type addRepresentation : Type -> Type -> Type diff --git a/rts/Sixten.Builtin.ll b/rts/Sixten.Builtin.ll index c43f19c4..baedce25 100644 --- a/rts/Sixten.Builtin.ll +++ b/rts/Sixten.Builtin.ll @@ -2,62 +2,55 @@ declare void @print_int(i64 %i) declare void @exit(i32) -@Sixten.Builtin.Int = unnamed_addr constant i64 8 -@Sixten.Builtin.Type = unnamed_addr constant i64 8 +@Sixten.Builtin.Int = unnamed_addr constant i64 u0x0000000800000000 +@Sixten.Builtin.Type = unnamed_addr constant i64 u0x0000000800000000 @Sixten.Builtin.EmptyRepresentation = unnamed_addr constant i64 0 -@Sixten.Builtin.WordRepresentation = unnamed_addr constant i64 8 +@Sixten.Builtin.PointerRepresentation = unnamed_addr constant i64 u0x0000000000000008 +@Sixten.Builtin.WordRepresentation = unnamed_addr constant i64 u0x0000000800000000 -define external fastcc { ptr, ptr } @Sixten.Builtin.unknown(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, ptr %destination, i64 %a) { +define external fastcc void @Sixten.Builtin.unknown(ptr %destination, i64 %a) { call void @exit(i32 7411) unreachable } -define external fastcc { i64, ptr, ptr } @Sixten.Builtin.addRepresentation(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %a, i64 %b) { +define external fastcc i64 @Sixten.Builtin.addRepresentation(i64 %a, i64 %b) { %result = add i64 %a, %b - %result_with_heap_pointer_and_limit1 = insertvalue { i64, ptr, ptr } undef, i64 %result, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_pointer, 1 - %result_with_heap_pointer_and_limit3 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit2, ptr %heap_limit, 2 - ret { i64, ptr, ptr } %result_with_heap_pointer_and_limit3 + ret i64 %result } -define external fastcc { i64, ptr, ptr } @Sixten.Builtin.maxRepresentation(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %a, i64 %b) { - %a_lt_b = icmp ult i64 %a, %b - %result = select i1 %a_lt_b, i64 %b, i64 %a - %result_with_heap_pointer_and_limit1 = insertvalue { i64, ptr, ptr } undef, i64 %result, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_pointer, 1 - %result_with_heap_pointer_and_limit3 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit2, ptr %heap_limit, 2 - ret { i64, ptr, ptr } %result_with_heap_pointer_and_limit3 +define external fastcc i64 @Sixten.Builtin.maxRepresentation(i64 %a, i64 %b) { + %a_ptrs = trunc i64 %a to i32 + %b_ptrs = trunc i64 %b to i32 + %a_non_ptrs64 = lshr i64 %a, 32 + %b_non_ptrs64 = lshr i64 %b, 32 + %a_non_ptrs = trunc i64 %a_non_ptrs64 to i32 + %b_non_ptrs = trunc i64 %b_non_ptrs64 to i32 + %a_ptrs_lt_b_ptrs = icmp ult i32 %a_ptrs, %b_ptrs + %result_ptrs = select i1 %a_ptrs_lt_b_ptrs, i32 %b_ptrs, i32 %a_ptrs + %a_non_ptrs_lt_b_non_ptrs = icmp ult i32 %a_non_ptrs, %b_non_ptrs + %result_non_ptrs = select i1 %a_non_ptrs_lt_b_non_ptrs, i32 %b_non_ptrs, i32 %a_non_ptrs + %result_lower = zext i32 %result_ptrs to i64 + %result_non_ptrs64 = zext i32 %result_non_ptrs to i64 + %result_upper = shl nuw i64 %result_non_ptrs64, 32 + %result = or i64 %result_lower, %result_upper + ret i64 %result } -define external fastcc { ptr, ptr } @Sixten.Builtin.printInt(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %tagged_i) { - %i = ashr i64 %tagged_i, 1 +define external fastcc void @Sixten.Builtin.printInt(i64 %i) { call void @print_int(i64 %i) - %result_with_heap_pointer_and_limit1 = insertvalue { ptr, ptr } undef, ptr %heap_pointer, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_limit, 1 - ret { ptr, ptr } %result_with_heap_pointer_and_limit2 } -define external fastcc { i64, ptr, ptr } @Sixten.Builtin.addInt(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %a, i64 %b) { +define external fastcc i64 @Sixten.Builtin.addInt(i64 %a, i64 %b) { %result = add i64 %a, %b - %result_with_heap_pointer_and_limit1 = insertvalue { i64, ptr, ptr } undef, i64 %result, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_pointer, 1 - %result_with_heap_pointer_and_limit3 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit2, ptr %heap_limit, 2 - ret { i64, ptr, ptr } %result_with_heap_pointer_and_limit3 + ret i64 %result } -define external fastcc { i64, ptr, ptr } @Sixten.Builtin.mulInt(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %a, i64 %b) { - %doubled_result = mul i64 %a, %b - %result = ashr i64 %doubled_result, 1 - %result_with_heap_pointer_and_limit1 = insertvalue { i64, ptr, ptr } undef, i64 %result, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_pointer, 1 - %result_with_heap_pointer_and_limit3 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit2, ptr %heap_limit, 2 - ret { i64, ptr, ptr } %result_with_heap_pointer_and_limit3 +define external fastcc i64 @Sixten.Builtin.mulInt(i64 %a, i64 %b) { + %result = mul i64 %a, %b + ret i64 %result } -define external fastcc { i64, ptr, ptr } @Sixten.Builtin.subInt(ptr %shadow_stack, ptr %heap_pointer, ptr %heap_limit, i64 %a, i64 %b) { +define external fastcc i64 @Sixten.Builtin.subInt(i64 %a, i64 %b) { %result = sub i64 %a, %b - %result_with_heap_pointer_and_limit1 = insertvalue { i64, ptr, ptr } undef, i64 %result, 0 - %result_with_heap_pointer_and_limit2 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit1, ptr %heap_pointer, 1 - %result_with_heap_pointer_and_limit3 = insertvalue { i64, ptr, ptr } %result_with_heap_pointer_and_limit2, ptr %heap_limit, 2 - ret { i64, ptr, ptr } %result_with_heap_pointer_and_limit3 + ret i64 %result } diff --git a/src/Builtin.hs b/src/Builtin.hs index 2095b1e9..01b274f6 100644 --- a/src/Builtin.hs +++ b/src/Builtin.hs @@ -99,6 +99,10 @@ pattern WordRepresentationName :: Name.Qualified pattern WordRepresentationName = "Sixten.Builtin.WordRepresentation" +pattern PointerRepresentationName :: Name.Qualified +pattern PointerRepresentationName = + "Sixten.Builtin.PointerRepresentation" + pattern AddRepresentationName :: Name.Qualified pattern AddRepresentationName = "Sixten.Builtin.addRepresentation" diff --git a/src/ClosureConverted/Representation.hs b/src/ClosureConverted/Representation.hs index defee8e8..8c092423 100644 --- a/src/ClosureConverted/Representation.hs +++ b/src/ClosureConverted/Representation.hs @@ -60,10 +60,10 @@ signature def = returnRepresentation <- typeRepresentation env' type_ pure $ Representation.FunctionSignature parameterRepresentations returnRepresentation Syntax.DataDefinition {} -> - pure $ Representation.ConstantSignature $ Representation.Direct Representation.Doesn'tContainHeapPointers + pure $ Representation.ConstantSignature Representation.Direct Syntax.ParameterisedDataDefinition _boxity tele -> - telescopeSignature context tele mempty \_ _ parameterRepresentations -> do - pure $ Representation.FunctionSignature parameterRepresentations $ Representation.Direct Representation.Doesn'tContainHeapPointers + telescopeSignature context tele mempty \_ _ parameterRepresentations -> + pure $ Representation.FunctionSignature parameterRepresentations Representation.Direct where context = Context.empty @@ -95,38 +95,38 @@ typeRepresentation :: Environment v -> Domain.Type -> M Representation typeRepresentation env type_ = case type_ of Domain.Neutral (Domain.Var _) _ -> - pure $ Representation.Indirect Representation.MightContainHeapPointers + pure Representation.Indirect -- TODO: Handle these special cases in a nicer way Domain.Neutral (Domain.Global (Name.Lifted Builtin.TypeName 0)) Tsil.Empty -> - pure $ Representation.Direct Representation.Doesn'tContainHeapPointers + pure Representation.Direct Domain.Neutral (Domain.Global (Name.Lifted Builtin.IntName 0)) Tsil.Empty -> - pure $ Representation.Direct Representation.Doesn'tContainHeapPointers + pure Representation.Direct Domain.Neutral (Domain.Global global) (Domain.groupSpine -> [Domain.GroupedApps args]) -> do globalCase global args Domain.Neutral (Domain.Global global) (Domain.groupSpine -> []) -> do globalCase global [] Domain.Neutral {} -> - pure $ Representation.Indirect Representation.MightContainHeapPointers + pure Representation.Indirect Domain.Con {} -> - pure $ Representation.Indirect Representation.MightContainHeapPointers + pure Representation.Indirect Domain.Lit {} -> - pure $ Representation.Indirect Representation.MightContainHeapPointers + pure Representation.Indirect Domain.Glued _ _ type' -> typeRepresentation env type' Domain.Lazy lazyType -> do type' <- force lazyType typeRepresentation env type' Domain.Pi {} -> - pure $ Representation.Direct Representation.MightContainHeapPointers + pure Representation.Direct Domain.Function {} -> - pure $ Representation.Direct Representation.Doesn'tContainHeapPointers + pure Representation.Direct where globalCase global@(Name.Lifted qualifiedName liftedNameNumber) args = do -- TODO caching definition <- fetch $ Query.ClosureConverted global case definition of Syntax.TypeDeclaration _ -> - pure $ Representation.Indirect Representation.MightContainHeapPointers + pure Representation.Indirect Syntax.ConstantDefinition term -> do value <- Evaluation.evaluate Environment.empty term type' <- Evaluation.apply env value args @@ -135,20 +135,20 @@ typeRepresentation env type_ = maybeType' <- Evaluation.applyFunction env (Telescope.fromVoid tele) args case maybeType' of Nothing -> - pure $ Representation.Direct Representation.MightContainHeapPointers -- a closure + pure Representation.Direct Just type' -> typeRepresentation env type' Syntax.DataDefinition Boxed _ -> - pure $ Representation.Direct Representation.MightContainHeapPointers + pure Representation.Direct Syntax.DataDefinition Unboxed constructors -> do unless (liftedNameNumber == 0) $ panic "ClosureConverted.Representation. Data with name number /= 0" unboxedDataRepresentation qualifiedName Environment.empty constructors Syntax.ParameterisedDataDefinition Boxed _ -> - pure $ Representation.Direct Representation.MightContainHeapPointers + pure Representation.Direct Syntax.ParameterisedDataDefinition Unboxed tele -> do unless (liftedNameNumber == 0) $ panic "ClosureConverted.Representation. Data with name number /= 0" maybeResult <- Evaluation.applyTelescope env (Telescope.fromVoid tele) args $ unboxedDataRepresentation qualifiedName - pure $ fromMaybe (Representation.Indirect Representation.MightContainHeapPointers) maybeResult + pure $ fromMaybe Representation.Indirect maybeResult unboxedDataRepresentation :: Name.Qualified -> Environment v -> Syntax.ConstructorDefinitions v -> M Representation unboxedDataRepresentation dataTypeName env (Syntax.ConstructorDefinitions constructors) = do @@ -164,8 +164,7 @@ unboxedDataRepresentation dataTypeName env (Syntax.ConstructorDefinitions constr Nothing -> fieldRepresentation Just _ -> constructorTagRepresentation <> fieldRepresentation where - constructorTagRepresentation = - Representation.Direct Representation.Doesn'tContainHeapPointers + constructorTagRepresentation = Representation.Direct constructorFieldRepresentation :: Environment v -> Domain.Type -> Representation -> M Representation constructorFieldRepresentation env type_ accumulatedRepresentation = do @@ -174,7 +173,7 @@ constructorFieldRepresentation env type_ accumulatedRepresentation = do Domain.Pi _ fieldType closure -> do fieldRepresentation <- typeRepresentation env fieldType case accumulatedRepresentation <> fieldRepresentation of - representation@(Representation.Indirect Representation.MightContainHeapPointers) -> + representation@Representation.Indirect -> pure representation accumulatedRepresentation' -> do (context', var) <- Environment.extend env @@ -199,7 +198,7 @@ compileData env dataTypeName (Syntax.ConstructorDefinitions constructors) = do (boxity, maybeTags) <- fetch $ Query.ConstructorRepresentations dataTypeName case boxity of Boxed -> - pure $ Syntax.Global (Name.Lifted Builtin.WordRepresentationName 0) + pure $ Syntax.Global (Name.Lifted Builtin.PointerRepresentationName 0) Unboxed -> do compiledConstructorFields <- forM (OrderedHashMap.toList constructors) \(_, type_) -> do type' <- Evaluation.evaluate env type_ diff --git a/src/ClosureConvertedToAssembly.hs b/src/ClosureConvertedToAssembly.hs index 04838d0d..7827bec4 100644 --- a/src/ClosureConvertedToAssembly.hs +++ b/src/ClosureConvertedToAssembly.hs @@ -58,7 +58,7 @@ runBuilder (Builder s) = evalStateT s BuilderState - { fresh = 3 + { fresh = 0 , instructions = mempty } @@ -140,9 +140,9 @@ globalConstantOperand name = do Indirect $ Assembly.GlobalConstant name $ case representation of Representation.Empty -> Assembly.WordPointer - Representation.Direct Representation.Doesn'tContainHeapPointers -> Assembly.Word - Representation.Direct Representation.MightContainHeapPointers -> Assembly.WordPointer - Representation.Indirect _ -> Assembly.WordPointer + Representation.Direct -> Assembly.Word + -- TODO: needs to be a reference pair + Representation.Indirect -> Assembly.WordPointer _ -> panic $ "ClosureConvertedToAssembly.globalConstantLocation: global without constant signature " <> show name @@ -195,7 +195,7 @@ extractHeapPointerConstructorTag nameSuggestion location = do typeOf :: Environment v -> Syntax.Term v -> Builder (Operand, Representation) typeOf env term = do (type_, typeRepresentation) <- Builder $ - lift $ do + lift do value <- Evaluation.evaluate (Context.toEnvironment env.context) term typeValue <- TypeOf.typeOf env.context value typeRepresentation <- ClosureConverted.Representation.typeRepresentation (Context.toEnvironment env.context) typeValue @@ -452,21 +452,18 @@ generateGlobal env name representation term = do Representation.Empty -> makeConstantDefinition Assembly.WordPointer do (_, releaseTerm) <- generateTypedTerm env term (Direct emptyTypeOperand) representation sequence_ releaseTerm - Representation.Direct _ -> makeConstantDefinition Assembly.Word do + Representation.Direct -> makeConstantDefinition Assembly.Word do (result, releaseTerm) <- generateTypedTerm env term (Direct directTypeOperand) representation directResult <- forceDirect result sequence_ releaseTerm initGlobal name Assembly.Word directResult - Representation.Indirect _ -> - indirectCase - where - indirectCase = do - makeConstantDefinition Assembly.WordPointer do - (type_, _representation) <- typeOf env term - typeSize <- sizeOfType type_ - globalPointer <- allocateGlobal "global" typeSize - storeTerm env term globalPointer type_ - initGlobal name Assembly.WordPointer globalPointer + Representation.Indirect -> + makeConstantDefinition Assembly.WordPointer do + (type_, _representation) <- typeOf env term + typeSize <- sizeOfType type_ + globalPointer <- allocateGlobal "global" typeSize + storeTerm env term globalPointer type_ + initGlobal name Assembly.WordPointer globalPointer makeConstantDefinition :: Assembly.Type @@ -523,13 +520,13 @@ generateFunction env returnRepresentation tele parameterRepresentations params = (_, releaseTerm) <- generateTypedTerm env term (Direct emptyTypeOperand) returnRepresentation sequence_ releaseTerm pure Assembly.Void - Representation.Direct _ -> + Representation.Direct -> makeFunctionDefinition (Assembly.Return Assembly.Word) (toList params) $ do (result, releaseTerm) <- generateTypedTerm env term (Direct directTypeOperand) returnRepresentation directResult <- forceDirect result sequence_ releaseTerm pure $ Assembly.Return directResult - Representation.Indirect _ -> do + Representation.Indirect -> do returnLocation <- freshLocal "return_location" makeFunctionDefinition Assembly.Void ((Assembly.WordPointer, returnLocation) : toList params) $ do (type_, _representation) <- typeOf env term @@ -540,13 +537,10 @@ generateFunction env returnRepresentation tele parameterRepresentations params = case parameterRepresentation of Representation.Empty -> pure (params, Empty) - Representation.Direct Representation.Doesn'tContainHeapPointers -> do + Representation.Direct -> do local <- freshLocal $ Assembly.NameSuggestion name pure (params Tsil.:> (Assembly.Word, local), Direct $ Assembly.LocalOperand local) - Representation.Direct Representation.MightContainHeapPointers -> do - local <- freshLocal $ Assembly.NameSuggestion name - pure (params Tsil.:> (Assembly.WordPointer, local), Indirect $ Assembly.LocalOperand local) - Representation.Indirect _ -> do + Representation.Indirect -> do local <- freshLocal $ Assembly.NameSuggestion name pure (params Tsil.:> (Assembly.WordPointer, local), Indirect $ Assembly.LocalOperand local) @@ -576,7 +570,7 @@ makeFunctionDefinition returnType parameters m = do generateType :: Environment v -> Syntax.Type v -> Builder Operand generateType env type_ = do - (type', maybeReleaseType) <- generateTypedTerm env type_ (Direct pointerBytesOperand) $ Representation.Direct Representation.Doesn'tContainHeapPointers + (type', maybeReleaseType) <- generateTypedTerm env type_ (Direct pointerBytesOperand) Representation.Direct case maybeReleaseType of Nothing -> pure type' @@ -587,14 +581,11 @@ generateType env type_ = do generateTypedTerm :: Environment v -> Syntax.Term v -> Operand -> Representation -> Builder (Operand, Maybe (Builder ())) generateTypedTerm env term type_ representation = do - let containsHeapPointers = Representation.containsHeapPointers representation - stackAllocateIt = do + let stackAllocateIt = do typeSize <- sizeOfType type_ stack <- saveStack termLocation <- stackAllocate "term_location" typeSize - let release = case containsHeapPointers of - Representation.Doesn'tContainHeapPointers -> pure () - Representation.MightContainHeapPointers -> releases termLocation typeSize + let release = releases termLocation typeSize storeTerm env term termLocation type_ pure ( Indirect termLocation @@ -602,17 +593,17 @@ generateTypedTerm env term type_ representation = do release restoreStack stack ) - case (term, containsHeapPointers) of - (Syntax.Var index, _) -> + case term of + Syntax.Var index -> pure (indexOperand index env, Nothing) - (Syntax.Global global, _) -> do + Syntax.Global global -> do operand <- globalConstantOperand global pure (operand, Nothing) - (Syntax.Con {}, _) -> + Syntax.Con {} -> stackAllocateIt -- TODO - (Syntax.Lit (Literal.Integer integer), _) -> + Syntax.Lit (Literal.Integer integer) -> pure (Direct $ Assembly.Lit $ Literal.Integer $ shiftL integer 1, Nothing) - (Syntax.Let _name term' termType body, _) -> do + Syntax.Let _name term' termType body -> do typeValue <- Builder $ lift $ Evaluation.evaluate (Context.toEnvironment env.context) termType typeRepresentation <- Builder $ lift $ ClosureConverted.Representation.typeRepresentation (Context.toEnvironment env.context) typeValue termType' <- generateType env termType @@ -620,9 +611,9 @@ generateTypedTerm env term type_ representation = do env' <- extend env termType term'' (result, releaseBody) <- generateTypedTerm env' body type_ representation pure (result, (>>) <$> releaseBody <*> releaseTerm) - (Syntax.Function _, _) -> + Syntax.Function _ -> pure (Direct pointerBytesOperand, Nothing) - (Syntax.Apply global arguments, Representation.Doesn'tContainHeapPointers) -> do + Syntax.Apply global arguments -> do signature <- fetch $ Query.ClosureConvertedSignature global let (argumentRepresentations, returnRepresentation) = case signature of @@ -636,22 +627,20 @@ generateTypedTerm env term type_ representation = do callVoid global arguments' deallocateArguments pure (Empty, Nothing) - Representation.Direct _containsHeapPointers -> do + Representation.Direct -> do (arguments', deallocateArguments) <- generateArguments env $ zip arguments argumentRepresentations result <- callDirect "call_result" global arguments' deallocateArguments pure (Direct result, Nothing) - Representation.Indirect _containsHeapPointers -> + Representation.Indirect -> stackAllocateIt - (Syntax.Pi {}, _) -> + Syntax.Pi {} -> pure (Direct pointerBytesOperand, Nothing) - (Syntax.Closure {}, _) -> - stackAllocateIt - (Syntax.ApplyClosure {}, _) -> + Syntax.Closure {} -> stackAllocateIt - (Syntax.Case {}, _) -> + Syntax.ApplyClosure {} -> stackAllocateIt - (_, Representation.MightContainHeapPointers) -> + Syntax.Case {} -> stackAllocateIt storeTerm @@ -747,10 +736,10 @@ storeTerm env term returnLocation returnType = case returnRepresentation of Representation.Empty -> callVoid global arguments' - Representation.Direct _containsHeapPointers -> do + Representation.Direct -> do result <- callDirect "call_result" global arguments' store returnLocation result - Representation.Indirect _containsHeapPointers -> do + Representation.Indirect -> callIndirect global arguments' returnLocation deallocateArguments Syntax.Pi {} -> @@ -859,41 +848,6 @@ storeBranch env constructorFieldBuilder tele returnLocation returnType = Telescope.Empty branch -> storeTerm env branch returnLocation returnType --- storeBoxedBranch --- :: Environment v --- -> Builder Assembly.Operand --- -> (Assembly.NameSuggestion -> Builder Assembly.Operand) --- -> Telescope Name Syntax.Type Syntax.Term v --- -> Assembly.Operand --- -> Operand --- -> Builder () --- storeBoxedBranch env constructorBasePointerBuilder constructorFieldOffsetBuilder tele returnLocation returnType = --- case tele of --- Telescope.Extend (Name name) type_ _plicity tele' -> do --- constructorFieldOffset <- constructorFieldOffsetBuilder $ Assembly.NameSuggestion $ name <> "_offset" --- type' <- generateType env type_ --- typeSize <- sizeOfType type' --- stack <- saveStack --- stackConstructorField <- stackAllocate (Assembly.NameSuggestion $ name <> "_stack") typeSize --- typeRepresentation <- Builder $ --- lift $ do --- typeValue <- Evaluation.evaluate (Context.toEnvironment env.context) type_ --- ClosureConverted.Representation.typeRepresentation (Context.toEnvironment env.context) typeValue --- release <- case Representation.containsHeapPointers typeRepresentation of --- Representation.Doesn'tContainHeapPointers -> pure (pure ()) --- Representation.MightContainHeapPointers -> registerShadowStackSlot typeSize stackConstructorField --- constructorBasePointer <- constructorBasePointerBuilder --- constructorField <- addPointer (Assembly.NameSuggestion name) constructorBasePointer constructorFieldOffset --- copy stackConstructorField (Indirect constructorField) typeSize --- let nextConstructorFieldOffsetBuilder nameSuggestion = --- add nameSuggestion constructorFieldOffset typeSize --- env' <- extend env type_ $ Indirect stackConstructorField --- storeBoxedBranch env' constructorBasePointerBuilder nextConstructorFieldOffsetBuilder tele' returnLocation returnType --- release --- restoreStack stack --- Telescope.Empty branch -> --- storeTerm env branch returnLocation returnType - generateArguments :: Environment v -> [(Syntax.Term v, Representation)] -> Builder ([(Assembly.Type, Assembly.Operand)], Builder ()) generateArguments env arguments = do (argumentGenerators, outerReleases) <- mapAndUnzipM (uncurry $ generateArgument env) arguments @@ -914,7 +868,7 @@ generateArgument env term representation = ( pure ([], pure ()) , sequence_ releaseTerm ) - Representation.Direct Representation.Doesn'tContainHeapPointers -> do + Representation.Direct -> do (term', releaseTerm) <- generateTypedTerm env term (Direct directTypeOperand) representation pure ( do @@ -922,10 +876,7 @@ generateArgument env term representation = pure ([(Assembly.Word, directTerm)], pure ()) , sequence_ releaseTerm ) - Representation.Direct Representation.MightContainHeapPointers -> indirectCase - Representation.Indirect _containsHeapPointers -> indirectCase - where - indirectCase = do + Representation.Indirect -> do (type_, representation_) <- typeOf env term (termOperand, releaseTermOperand) <- generateTypedTerm env term type_ representation_ pure diff --git a/src/Representation.hs b/src/Representation.hs index 6f652432..7e679ddf 100644 --- a/src/Representation.hs +++ b/src/Representation.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Representation where @@ -15,58 +16,30 @@ data Signature data Representation = Empty - | Direct !ContainsHeapPointers - | Indirect !ContainsHeapPointers - deriving (Eq, Ord, Show, Generic, Hashable) - -data ContainsHeapPointers - = Doesn'tContainHeapPointers - | MightContainHeapPointers + | Direct + | Indirect deriving (Eq, Ord, Show, Generic, Hashable) instance Semigroup Representation where Empty <> representation = representation representation <> Empty = representation - representation1 <> representation2 = - Indirect $ containsHeapPointers representation1 <> containsHeapPointers representation2 - -containsHeapPointers :: Representation -> ContainsHeapPointers -containsHeapPointers Empty = Doesn'tContainHeapPointers -containsHeapPointers (Direct cp) = cp -containsHeapPointers (Indirect cp) = cp + representation1 <> representation2 = Indirect instance Monoid Representation where - mempty = - Empty + mempty = Empty instance Pretty Representation where - pretty representation = - case representation of - Empty -> - "empty" - Direct MightContainHeapPointers -> - "direct*" - Direct Doesn'tContainHeapPointers -> - "direct" - Indirect MightContainHeapPointers -> - "indirect*" - Indirect Doesn'tContainHeapPointers -> - "indirect" - -instance Semigroup ContainsHeapPointers where - MightContainHeapPointers <> _ = MightContainHeapPointers - _ <> MightContainHeapPointers = MightContainHeapPointers - Doesn'tContainHeapPointers <> Doesn'tContainHeapPointers = Doesn'tContainHeapPointers - -instance Monoid ContainsHeapPointers where - mempty = Doesn'tContainHeapPointers + pretty = \case + Empty -> "empty" + Direct -> "direct" + Indirect -> "indirect" maxM :: Monad m => [m Representation] -> m Representation maxM [] = pure mempty maxM (m : ms) = do representation <- m case representation of - Indirect MightContainHeapPointers -> + Indirect -> pure representation _ -> max representation <$> maxM ms