From d66ec6d34defd6e53b508ecdfe98c7d0daa0e7b7 Mon Sep 17 00:00:00 2001 From: Folkert Date: Thu, 30 Mar 2023 21:20:45 +0200 Subject: [PATCH] move RustGlue.roc closer to what we have on the ts branch --- crates/glue/platform/File.roc | 5 + crates/glue/platform/InternalTypeId.roc | 11 ++ .../{src/RocType.roc => platform/Shape.roc} | 68 +---------- crates/glue/platform/Target.roc | 22 ++++ crates/glue/platform/TypeId.roc | 5 + crates/glue/platform/Types.roc | 61 ++++++++++ crates/glue/platform/main.roc | 9 ++ crates/glue/src/RustGlue.roc | 112 +++++++----------- 8 files changed, 163 insertions(+), 130 deletions(-) create mode 100644 crates/glue/platform/File.roc create mode 100644 crates/glue/platform/InternalTypeId.roc rename crates/glue/{src/RocType.roc => platform/Shape.roc} (69%) create mode 100644 crates/glue/platform/Target.roc create mode 100644 crates/glue/platform/TypeId.roc create mode 100644 crates/glue/platform/Types.roc create mode 100644 crates/glue/platform/main.roc diff --git a/crates/glue/platform/File.roc b/crates/glue/platform/File.roc new file mode 100644 index 0000000000..da7a99e517 --- /dev/null +++ b/crates/glue/platform/File.roc @@ -0,0 +1,5 @@ +interface File + exposes [File] + imports [] + +File : { name : Str, content : Str } diff --git a/crates/glue/platform/InternalTypeId.roc b/crates/glue/platform/InternalTypeId.roc new file mode 100644 index 0000000000..ebdce6d173 --- /dev/null +++ b/crates/glue/platform/InternalTypeId.roc @@ -0,0 +1,11 @@ +interface InternalTypeId + exposes [InternalTypeId, fromNat, toNat] + imports [] + +InternalTypeId : Nat + +toNat : InternalTypeId -> Nat +toNat = \x -> x + +fromNat : Nat -> InternalTypeId +fromNat = \x -> x diff --git a/crates/glue/src/RocType.roc b/crates/glue/platform/Shape.roc similarity index 69% rename from crates/glue/src/RocType.roc rename to crates/glue/platform/Shape.roc index eef0bac5a8..da5767c3be 100644 --- a/crates/glue/src/RocType.roc +++ b/crates/glue/platform/Shape.roc @@ -1,68 +1,8 @@ -platform "roc-lang/glue" - requires {} { makeGlue : List Types -> Result (List File) Str } - exposes [] - packages {} - imports [] - provides [makeGlueForHost] +interface Shape + exposes [Shape, RocNum, RocTagUnion, RocStructFields, RocFn, RocSingleTagPayload] + imports [TypeId.{ TypeId }] -makeGlueForHost : List Types -> Result (List File) Str -makeGlueForHost = \x -> makeGlue x - -File : { name : Str, content : Str } - -# TODO move into separate Target.roc interface once glue works across interfaces. -Target : { - architecture : Architecture, - operatingSystem : OperatingSystem, -} - -Architecture : [ - Aarch32, - Aarch64, - Wasm32, - X86x32, - X86x64, -] - -OperatingSystem : [ - Windows, - Unix, - Wasi, -] - -# TODO change this to an opaque type once glue supports abilities. -TypeId : Nat -# has [ -# Eq { -# isEq: isEqTypeId, -# }, -# Hash { -# hash: hashTypeId, -# } -# ] -# isEqTypeId = \@TypeId lhs, @TypeId rhs -> lhs == rhs -# hashTypeId = \hasher, @TypeId id -> Hash.hash hasher id -# TODO: switch AssocList uses to Dict once roc_std is updated. -Tuple1 : [T Str TypeId] -Tuple2 : [T TypeId (List TypeId)] - -Types : { - # These are all indexed by TypeId - types : List RocType, - sizes : List U32, - aligns : List U32, - - # Needed to check for duplicates - typesByName : List Tuple1, - - ## Dependencies - that is, which type depends on which other type. - ## This is important for declaration order in C; we need to output a - ## type declaration earlier in the file than where it gets referenced by another type. - deps : List Tuple2, - target : Target, -} - -RocType : [ +Shape : [ RocStr, Bool, RocResult TypeId TypeId, diff --git a/crates/glue/platform/Target.roc b/crates/glue/platform/Target.roc new file mode 100644 index 0000000000..3103486974 --- /dev/null +++ b/crates/glue/platform/Target.roc @@ -0,0 +1,22 @@ +interface Target + exposes [Target, Architecture, OperatingSystem] + imports [] + +Target : { + architecture : Architecture, + operatingSystem : OperatingSystem, +} + +Architecture : [ + Aarch32, + Aarch64, + Wasm32, + X86x32, + X86x64, +] + +OperatingSystem : [ + Windows, + Unix, + Wasi, +] diff --git a/crates/glue/platform/TypeId.roc b/crates/glue/platform/TypeId.roc new file mode 100644 index 0000000000..18e1b88776 --- /dev/null +++ b/crates/glue/platform/TypeId.roc @@ -0,0 +1,5 @@ +interface TypeId + exposes [TypeId] + imports [InternalTypeId.{ InternalTypeId }] + +TypeId : InternalTypeId diff --git a/crates/glue/platform/Types.roc b/crates/glue/platform/Types.roc new file mode 100644 index 0000000000..c65334d85f --- /dev/null +++ b/crates/glue/platform/Types.roc @@ -0,0 +1,61 @@ +interface Types + exposes [Types, shape, size, alignment, target, walkShapes] + imports [Shape.{ Shape }, TypeId.{ TypeId }, Target.{ Target }, InternalTypeId] + +# TODO: switch AssocList uses to Dict once roc_std is updated. +Tuple1 : [T Str TypeId] +Tuple2 : [T TypeId (List TypeId)] + +Types := { + # These are all indexed by TypeId + types : List Shape, + sizes : List U32, + aligns : List U32, + + # Needed to check for duplicates + typesByName : List Tuple1, + + ## Dependencies - that is, which type depends on which other type. + ## This is important for declaration order in C; we need to output a + ## type declaration earlier in the file than where it gets referenced by another type. + deps : List Tuple2, + target : Target, +} + +target : Types -> Target +target = \@Types types -> types.target + +walkShapes : Types, state, (state, Shape, TypeId -> state) -> state +walkShapes = \@Types { types: shapes }, originalState, update -> + List.walk shapes { index: 0, state: originalState } \{ index, state }, elem -> + id = InternalTypeId.fromNat index + + { index: index + 1, state: update state elem id } + |> .state + +shape : Types, TypeId -> Shape +shape = \@Types types, id -> + when List.get types.types (InternalTypeId.toNat id) is + Ok answer -> answer + Err OutOfBounds -> + idStr = Num.toStr (InternalTypeId.toNat id) + + crash "TypeId #\(idStr) was not found in Types. This should never happen, and means there was a bug in `roc glue`. If you have time, please open an issue at " + +alignment : Types, TypeId -> U32 +alignment = \@Types types, id -> + when List.get types.aligns (InternalTypeId.toNat id) is + Ok answer -> answer + Err OutOfBounds -> + idStr = Num.toStr (InternalTypeId.toNat id) + + crash "TypeId #\(idStr) was not found in Types. This should never happen, and means there was a bug in `roc glue`. If you have time, please open an issue at " + +size : Types, TypeId -> U32 +size = \@Types types, id -> + when List.get types.sizes (InternalTypeId.toNat id) is + Ok answer -> answer + Err OutOfBounds -> + idStr = Num.toStr (InternalTypeId.toNat id) + + crash "TypeId #\(idStr) was not found in Types. This should never happen, and means there was a bug in `roc glue`. If you have time, please open an issue at " diff --git a/crates/glue/platform/main.roc b/crates/glue/platform/main.roc new file mode 100644 index 0000000000..8abd83a981 --- /dev/null +++ b/crates/glue/platform/main.roc @@ -0,0 +1,9 @@ +platform "roc-lang/glue" + requires {} { makeGlue : List Types -> Result (List File) Str } + exposes [Shape, File, Types, TypeId, Target] + packages {} + imports [Types.{ Types }, File.{ File }] + provides [makeGlueForHost] + +makeGlueForHost : List Types -> Result (List File) Str +makeGlueForHost = \types -> makeGlue types diff --git a/crates/glue/src/RustGlue.roc b/crates/glue/src/RustGlue.roc index cab6b65541..60d16c4f6d 100644 --- a/crates/glue/src/RustGlue.roc +++ b/crates/glue/src/RustGlue.roc @@ -1,12 +1,14 @@ app "rust-glue" - packages { pf: "RocType.roc" } - imports [] + packages { pf: "../platform/main.roc" } + imports [pf.Types.{ Types }, pf.File.{ File }, pf.TypeId.{ TypeId }] provides [makeGlue] to pf -makeGlue = \types -> +makeGlue : List Types -> Result (List File) Str +makeGlue = \typesByArch -> modFileContent = - List.walk types "" \content, { target } -> - archStr = archName target.architecture + List.walk typesByArch "" \content, types -> + arch = (Types.target types).architecture + archStr = archName arch Str.concat content @@ -18,15 +20,15 @@ makeGlue = \types -> """ - types - |> List.map typesWithDict + typesByArch |> List.map convertTypesToFile |> List.append { name: "mod.rs", content: modFileContent } |> Ok +convertTypesToFile : Types -> File convertTypesToFile = \types -> content = - walkWithIndex types.types fileHeader \buf, id, type -> + Types.walkShapes types fileHeader \buf, type, id -> when type is Struct { name, fields } -> generateStruct buf types id name fields Public @@ -84,13 +86,16 @@ convertTypesToFile = \types -> # These types don't need to be declared in Rust. # TODO: Eventually we want to generate roc_std. So these types will need to be emitted. buf - archStr = archName types.target.architecture + + arch = (Types.target types).architecture + archStr = archName arch { name: "\(archStr).rs", content, } +generateStruct : Str, Types, TypeId, _, _, _ -> Str generateStruct = \buf, types, id, name, structFields, visibility -> escapedName = escapeKW name repr = @@ -108,7 +113,7 @@ generateStruct = \buf, types, id, name, structFields, visibility -> Public -> "pub" Private -> "" - structType = getType types id + structType = Types.shape types id buf |> generateDeriveStr types structType IncludeDebug @@ -221,7 +226,7 @@ generateNonRecursiveTagUnion = \buf, types, id, name, tags, discriminantSize, di """ |> Str.concat "// TODO: NonRecursive TagUnion constructor impls\n\n" |> \b -> - type = getType types id + type = Types.shape types id if cannotDeriveCopy types type then # A custom drop impl is only needed when we can't derive copy. b @@ -285,7 +290,7 @@ generateTagUnionDropPayload = \buf, types, selfMut, tags, discriminantName, disc buf |> writeTagImpls tags discriminantName indents \name, payload -> when payload is - Some id if cannotDeriveCopy types (getType types id) -> + Some id if cannotDeriveCopy types (Types.shape types id) -> "unsafe {{ core::mem::ManuallyDrop::drop(&mut \(selfMut).\(name)) }}," _ -> @@ -313,6 +318,7 @@ writeTagImpls = \buf, tags, discriminantName, indents, f -> |> writeIndents indents |> Str.concat "}\n" +generateTagUnionSizer : Str, Types, TypeId, _ -> Str generateTagUnionSizer = \buf, types, id, tags -> if List.len tags > 1 then # When there's a discriminant (so, multiple tags) and there is @@ -355,7 +361,7 @@ generateUnionField = \types -> typeStr = typeName types id escapedFieldName = escapeKW fieldName - type = getType types id + type = Types.shape types id fullTypeStr = if cannotDeriveCopy types type then # types with pointers need ManuallyDrop @@ -614,40 +620,40 @@ cannotDeriveCopy = \types, type -> Unit | Unsized | EmptyTagUnion | Bool | Num _ | TagUnion (Enumeration _) | Function _ -> Bool.false RocStr | RocList _ | RocDict _ _ | RocSet _ | RocBox _ | TagUnion (NullableUnwrapped _) | TagUnion (NullableWrapped _) | TagUnion (Recursive _) | TagUnion (NonNullableUnwrapped _) | RecursivePointer _ -> Bool.true TagUnion (SingleTagStruct { payload: HasNoClosure fields }) -> - List.any fields \{ id } -> cannotDeriveCopy types (getType types id) + List.any fields \{ id } -> cannotDeriveCopy types (Types.shape types id) TagUnion (SingleTagStruct { payload: HasClosure fields }) -> - List.any fields \{ id } -> cannotDeriveCopy types (getType types id) + List.any fields \{ id } -> cannotDeriveCopy types (Types.shape types id) TagUnion (NonRecursive { tags }) -> List.any tags \{ payload } -> when payload is - Some id -> cannotDeriveCopy types (getType types id) + Some id -> cannotDeriveCopy types (Types.shape types id) None -> Bool.false RocResult okId errId -> - cannotDeriveCopy types (getType types okId) - || cannotDeriveCopy types (getType types errId) + cannotDeriveCopy types (Types.shape types okId) + || cannotDeriveCopy types (Types.shape types errId) Struct { fields: HasNoClosure fields } | TagUnionPayload { fields: HasNoClosure fields } -> - List.any fields \{ id } -> cannotDeriveCopy types (getType types id) + List.any fields \{ id } -> cannotDeriveCopy types (Types.shape types id) Struct { fields: HasClosure fields } | TagUnionPayload { fields: HasClosure fields } -> - List.any fields \{ id } -> cannotDeriveCopy types (getType types id) + List.any fields \{ id } -> cannotDeriveCopy types (Types.shape types id) cannotDeriveDefault = \types, type -> when type is Unit | Unsized | EmptyTagUnion | TagUnion _ | RocResult _ _ | RecursivePointer _ | Function _ -> Bool.true RocStr | Bool | Num _ | Struct { fields: HasClosure _ } | TagUnionPayload { fields: HasClosure _ } -> Bool.false RocList id | RocSet id | RocBox id -> - cannotDeriveDefault types (getType types id) + cannotDeriveDefault types (Types.shape types id) RocDict keyId valId -> - cannotDeriveCopy types (getType types keyId) - || cannotDeriveCopy types (getType types valId) + cannotDeriveCopy types (Types.shape types keyId) + || cannotDeriveCopy types (Types.shape types valId) Struct { fields: HasNoClosure fields } | TagUnionPayload { fields: HasNoClosure fields } -> - List.any fields \{ id } -> cannotDeriveDefault types (getType types id) + List.any fields \{ id } -> cannotDeriveDefault types (Types.shape types id) hasFloat = \types, type -> hasFloatHelp types type (Set.empty {}) @@ -664,40 +670,40 @@ hasFloatHelp = \types, type, doNotRecurse -> Unit | Unsized | EmptyTagUnion | RocStr | Bool | TagUnion (Enumeration _) | Function _ -> Bool.false RocList id | RocSet id | RocBox id -> - hasFloatHelp types (getType types id) doNotRecurse + hasFloatHelp types (Types.shape types id) doNotRecurse RocDict id0 id1 | RocResult id0 id1 -> - hasFloatHelp types (getType types id0) doNotRecurse - || hasFloatHelp types (getType types id1) doNotRecurse + hasFloatHelp types (Types.shape types id0) doNotRecurse + || hasFloatHelp types (Types.shape types id1) doNotRecurse Struct { fields: HasNoClosure fields } | TagUnionPayload { fields: HasNoClosure fields } -> - List.any fields \{ id } -> hasFloatHelp types (getType types id) doNotRecurse + List.any fields \{ id } -> hasFloatHelp types (Types.shape types id) doNotRecurse Struct { fields: HasClosure fields } | TagUnionPayload { fields: HasClosure fields } -> - List.any fields \{ id } -> hasFloatHelp types (getType types id) doNotRecurse + List.any fields \{ id } -> hasFloatHelp types (Types.shape types id) doNotRecurse TagUnion (SingleTagStruct { payload: HasNoClosure fields }) -> - List.any fields \{ id } -> hasFloatHelp types (getType types id) doNotRecurse + List.any fields \{ id } -> hasFloatHelp types (Types.shape types id) doNotRecurse TagUnion (SingleTagStruct { payload: HasClosure fields }) -> - List.any fields \{ id } -> hasFloatHelp types (getType types id) doNotRecurse + List.any fields \{ id } -> hasFloatHelp types (Types.shape types id) doNotRecurse TagUnion (Recursive { tags }) -> List.any tags \{ payload } -> when payload is - Some id -> hasFloatHelp types (getType types id) doNotRecurse + Some id -> hasFloatHelp types (Types.shape types id) doNotRecurse None -> Bool.false TagUnion (NonRecursive { tags }) -> List.any tags \{ payload } -> when payload is - Some id -> hasFloatHelp types (getType types id) doNotRecurse + Some id -> hasFloatHelp types (Types.shape types id) doNotRecurse None -> Bool.false TagUnion (NullableWrapped { tags }) -> List.any tags \{ payload } -> when payload is - Some id -> hasFloatHelp types (getType types id) doNotRecurse + Some id -> hasFloatHelp types (Types.shape types id) doNotRecurse None -> Bool.false TagUnion (NonNullableUnwrapped { payload }) -> @@ -706,7 +712,7 @@ hasFloatHelp = \types, type, doNotRecurse -> else nextDoNotRecurse = Set.insert doNotRecurse payload - hasFloatHelp types (getType types payload) nextDoNotRecurse + hasFloatHelp types (Types.shape types payload) nextDoNotRecurse TagUnion (NullableUnwrapped { nonNullPayload }) -> if Set.contains doNotRecurse nonNullPayload then @@ -714,7 +720,7 @@ hasFloatHelp = \types, type, doNotRecurse -> else nextDoNotRecurse = Set.insert doNotRecurse nonNullPayload - hasFloatHelp types (getType types nonNullPayload) nextDoNotRecurse + hasFloatHelp types (Types.shape types nonNullPayload) nextDoNotRecurse RecursivePointer payload -> if Set.contains doNotRecurse payload then @@ -722,10 +728,10 @@ hasFloatHelp = \types, type, doNotRecurse -> else nextDoNotRecurse = Set.insert doNotRecurse payload - hasFloatHelp types (getType types payload) nextDoNotRecurse + hasFloatHelp types (Types.shape types payload) nextDoNotRecurse typeName = \types, id -> - when getType types id is + when Types.shape types id is Unit -> "()" Unsized -> "roc_std::RocList" EmptyTagUnion -> "std::convert::Infallible" @@ -785,27 +791,12 @@ typeName = \types, id -> TagUnion (SingleTagStruct { name }) -> escapeKW name Function { functionName } -> escapeKW functionName -getType = \types, id -> - when List.get types.types id is - Ok type -> type - Err _ -> crash "unreachable" - getSizeRoundedToAlignment = \types, id -> - alignment = getAlignment types id + alignment = Types.alignment types id - getSizeIgnoringAlignment types id + Types.size types id |> roundUpToAlignment alignment -getSizeIgnoringAlignment = \types, id -> - when List.get types.sizes id is - Ok size -> size - Err _ -> crash "unreachable" - -getAlignment = \types, id -> - when List.get types.aligns id is - Ok align -> align - Err _ -> crash "unreachable" - roundUpToAlignment = \width, alignment -> when alignment is 0 -> width @@ -931,14 +922,3 @@ escapeKW = \input -> "r#\(input)" else input - -# This is a temporary helper until roc_std::roc_dict is update. -# after that point, Dict will be passed in directly. -typesWithDict = \{ types, sizes, aligns, typesByName, deps, target } -> { - types, - sizes, - aligns, - typesByName: Dict.fromList typesByName, - deps: Dict.fromList deps, - target, -}