Stabel

Check-in [c5016144d8]
Login
Overview
Comment:Discovered, and fixed, several issues related to arrays used in multi functions. What remains is to box elements of an array which holds a union.
Timelines: family | ancestors | descendants | both | arrays
Files: files | file ages | folders
SHA3-256: c5016144d818a3273966c9a334b160774bdb69f5f630a4b9e15b3ad546ec9c18
User & Date: robin.hansen on 2021-08-30 20:06:46
Other Links: branch diff | manifest | tags
Context
2021-08-31
19:10
Box elements of array when array contains a union of types. check-in: 775ec8d96b user: robin.hansen tags: arrays
2021-08-30
20:06
Discovered, and fixed, several issues related to arrays used in multi functions. What remains is to ... check-in: c5016144d8 user: robin.hansen tags: arrays
17:02
It's now possible to reference arrays in the type system. check-in: 9b06579c64 user: robin.hansen tags: arrays
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified src/Stabel/Codegen.elm from [65a3071605] to [2b90edb681].

184
185
186
187
188
189
190
191
192
193
194
195
196
197



198









199
200
201





202
203
204
205
206
207
208
...
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
...
435
436
437
438
439
440
441



442
443
444
445
446
447
448
...
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
        ( newNode, updatedContext ) =
            case node of
                AST.IntLiteral _ val ->
                    ( IntLiteral val
                    , context
                    )

                AST.ArrayLiteral _ nodes _ ->
                    let
                        ( _, codeGenNodes, nextContext ) =
                            List.foldl
                                (astNodeToCodegenNode def)
                                ( [], [], context )
                                nodes



                    in









                    ( ArrayLiteral (List.reverse codeGenNodes)
                    , nextContext
                    )






                AST.Function _ fn _ ->
                    let
                        ( fnId, newContext ) =
                            idForFunction fn.name context
                    in
                    ( Function fnId fn.name
................................................................................
                |> List.filterMap maybeBox
                |> maybeCons maybeBoxLeadingElement

        maybeBox ( idx, leftType, rightType ) =
            case ( leftType, rightType ) of
                ( _, Type.Union _ members ) ->
                    unionBoxMap members
                        |> List.find (\( t, _ ) -> t == leftType)
                        |> Maybe.map Tuple.second
                        |> Maybe.map (Box idx)

                _ ->
                    Nothing

        maybeBoxLeadingElement =
            case ( List.head stackInScope, isMultiFunction node, List.head nodeType.input ) of
                ( Just _, True, Just (Type.Union _ _) ) ->
                    -- Already handled by maybePromoteInt
                    Nothing

                ( Just _, True, Just nodeLeadingType ) ->
                    if requiresBoxingInPatternMatch nodeLeadingType then
                        let
                            idx =
                                max 0 (List.length nodeType.input - 1)
................................................................................
requiresBoxingInPatternMatch type_ =
    case type_ of
        Type.Int ->
            True

        Type.Generic _ ->
            True




        _ ->
            False


multiFnToInstructions :
    Context
................................................................................
    -> Int
    -> Context
    -> ( Wasm.Instruction, Context )
makeInequalityTest boxMap selfIndex ((AST.TypeMatch _ typeFromTypeMatch _) as t_) localIdx context =
    let
        maybeBoxId =
            boxMap
                |> List.find (\( boxedType, _ ) -> boxedType == typeFromTypeMatch)
                |> Maybe.map Tuple.second
    in
    case ( t_, maybeBoxId ) of
        ( AST.TypeMatch _ Type.Int conditions, Just boxId ) ->
            ( Wasm.Batch
                [ Wasm.Local_Get localIdx
                , Wasm.I32_Load -- Load instance id







|

|




>
>
>

>
>
>
>
>
>
>
>
>
|
|
|
>
>
>
>
>







 







|









|







 







>
>
>







 







|







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
...
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
        ( newNode, updatedContext ) =
            case node of
                AST.IntLiteral _ val ->
                    ( IntLiteral val
                    , context
                    )

                AST.ArrayLiteral _ nodes arrayType ->
                    let
                        ( _, codeGenNodesReversed, nextContext ) =
                            List.foldl
                                (astNodeToCodegenNode def)
                                ( [], [], context )
                                nodes

                        codeGenNodes =
                            List.reverse codeGenNodesReversed
                    in
                    case arrayType of
                        Type.Union _ members ->
                            {-
                               TODO:
                                  unionBoxMap members
                                      |> List.find (\( t, _ ) -> Type.equalBaseType t leftType)
                                      |> Maybe.map Tuple.second
                                      |> Maybe.map (Box idx)
                            -}
                            ( ArrayLiteral codeGenNodes
                            , nextContext
                            )

                        _ ->
                            ( ArrayLiteral codeGenNodes
                            , nextContext
                            )

                AST.Function _ fn _ ->
                    let
                        ( fnId, newContext ) =
                            idForFunction fn.name context
                    in
                    ( Function fnId fn.name
................................................................................
                |> List.filterMap maybeBox
                |> maybeCons maybeBoxLeadingElement

        maybeBox ( idx, leftType, rightType ) =
            case ( leftType, rightType ) of
                ( _, Type.Union _ members ) ->
                    unionBoxMap members
                        |> List.find (\( t, _ ) -> Type.equalBaseType t leftType)
                        |> Maybe.map Tuple.second
                        |> Maybe.map (Box idx)

                _ ->
                    Nothing

        maybeBoxLeadingElement =
            case ( List.head stackInScope, isMultiFunction node, List.head nodeType.input ) of
                ( Just _, True, Just (Type.Union _ _) ) ->
                    -- Already handled by maybeBox
                    Nothing

                ( Just _, True, Just nodeLeadingType ) ->
                    if requiresBoxingInPatternMatch nodeLeadingType then
                        let
                            idx =
                                max 0 (List.length nodeType.input - 1)
................................................................................
requiresBoxingInPatternMatch type_ =
    case type_ of
        Type.Int ->
            True

        Type.Generic _ ->
            True

        Type.Array _ ->
            True

        _ ->
            False


multiFnToInstructions :
    Context
................................................................................
    -> Int
    -> Context
    -> ( Wasm.Instruction, Context )
makeInequalityTest boxMap selfIndex ((AST.TypeMatch _ typeFromTypeMatch _) as t_) localIdx context =
    let
        maybeBoxId =
            boxMap
                |> List.find (\( boxedType, _ ) -> Type.equalBaseType boxedType typeFromTypeMatch)
                |> Maybe.map Tuple.second
    in
    case ( t_, maybeBoxId ) of
        ( AST.TypeMatch _ Type.Int conditions, Just boxId ) ->
            ( Wasm.Batch
                [ Wasm.Local_Get localIdx
                , Wasm.I32_Load -- Load instance id

Modified src/Stabel/Data/Type.elm from [789a945a65] to [50cc86fb14].

1
2
3
4
5

6
7
8
9
10
11
12
..
71
72
73
74
75
76
77



78
79
80
81
82
83
84
..
92
93
94
95
96
97
98



















99
100
101
102
103
104
105
...
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
module Stabel.Data.Type exposing
    ( FunctionType
    , Type(..)
    , compatibleFunctions
    , emptyFunctionType

    , functionTypeToString
    , genericName
    , genericlyCompatible
    , isGeneric
    , referencedGenerics
    , toDisplayString
    )
................................................................................
                |> List.foldl Set.union Set.empty

        Union _ members ->
            members
                |> List.map referencedGenerics
                |> List.foldl Set.union Set.empty




        _ ->
            Set.empty


genericlyCompatible : Type -> Type -> Bool
genericlyCompatible lhs rhs =
    case ( lhs, rhs ) of
................................................................................
            True

        ( CustomGeneric lName _, CustomGeneric rName _ ) ->
            lName == rName

        ( Union _ lMems, Union _ rMems ) ->
            lMems == rMems




















        _ ->
            lhs == rhs


sameCategory : Type -> Type -> Bool
sameCategory lhs rhs =
................................................................................

        ( (Array lMember) :: annotatedRest, (Array rMember) :: inferredRest ) ->
            let
                ( _, compatibleMembers ) =
                    compatibleTypeLists [ lMember ] [ rMember ] Dict.empty
            in
            if compatibleMembers then
                ( rangeDict, True )

            else
                ( rangeDict, False )

        ( (Union _ lMembers) :: annotatedRest, (Union _ rMembers) :: inferredRest ) ->
            let
                lSet =





>







 







>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
..
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
module Stabel.Data.Type exposing
    ( FunctionType
    , Type(..)
    , compatibleFunctions
    , emptyFunctionType
    , equalBaseType
    , functionTypeToString
    , genericName
    , genericlyCompatible
    , isGeneric
    , referencedGenerics
    , toDisplayString
    )
................................................................................
                |> List.foldl Set.union Set.empty

        Union _ members ->
            members
                |> List.map referencedGenerics
                |> List.foldl Set.union Set.empty

        Array val ->
            referencedGenerics val

        _ ->
            Set.empty


genericlyCompatible : Type -> Type -> Bool
genericlyCompatible lhs rhs =
    case ( lhs, rhs ) of
................................................................................
            True

        ( CustomGeneric lName _, CustomGeneric rName _ ) ->
            lName == rName

        ( Union _ lMems, Union _ rMems ) ->
            lMems == rMems

        ( Array lT, Array rT ) ->
            genericlyCompatible lT rT

        _ ->
            lhs == rhs


equalBaseType : Type -> Type -> Bool
equalBaseType lhs rhs =
    case ( lhs, rhs ) of
        ( Generic _, Generic _ ) ->
            True

        ( Array _, Array _ ) ->
            True

        ( CustomGeneric lName _, CustomGeneric rName _ ) ->
            lName == rName

        _ ->
            lhs == rhs


sameCategory : Type -> Type -> Bool
sameCategory lhs rhs =
................................................................................

        ( (Array lMember) :: annotatedRest, (Array rMember) :: inferredRest ) ->
            let
                ( _, compatibleMembers ) =
                    compatibleTypeLists [ lMember ] [ rMember ] Dict.empty
            in
            if compatibleMembers then
                compatibleTypeLists annotatedRest inferredRest rangeDict

            else
                ( rangeDict, False )

        ( (Union _ lMembers) :: annotatedRest, (Union _ rMembers) :: inferredRest ) ->
            let
                lSet =

Modified src/Stabel/Qualifier.elm from [854b5fd650] to [39463bf45b].

903
904
905
906
907
908
909







910
911
912
913
914
915
916

        Parser.TypeMatch range (Parser.LocalRef "Int" []) [ ( "value", Parser.LiteralInt val ) ] ->
            Ok <|
                TypeMatch
                    (qualifiedRange range)
                    Type.Int
                    [ TypeMatchCond "value" Type.Int (LiteralInt val) ]








        Parser.TypeMatch range (Parser.Generic sym) [] ->
            Ok <| TypeMatch (qualifiedRange range) (Type.Generic sym) []

        Parser.TypeMatch range (Parser.LocalRef name []) patterns ->
            case qualifiedNameToMatch (qualifiedRange range) (qualifyName config name) patterns of
                (Err (UnknownTypeRef _ _)) as errMsg ->







>
>
>
>
>
>
>







903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923

        Parser.TypeMatch range (Parser.LocalRef "Int" []) [ ( "value", Parser.LiteralInt val ) ] ->
            Ok <|
                TypeMatch
                    (qualifiedRange range)
                    Type.Int
                    [ TypeMatchCond "value" Type.Int (LiteralInt val) ]

        Parser.TypeMatch range (Parser.LocalRef "Array" []) [] ->
            Ok <|
                TypeMatch
                    (qualifiedRange range)
                    (Type.Array (Type.Generic "*a"))
                    []

        Parser.TypeMatch range (Parser.Generic sym) [] ->
            Ok <| TypeMatch (qualifiedRange range) (Type.Generic sym) []

        Parser.TypeMatch range (Parser.LocalRef name []) patterns ->
            case qualifiedNameToMatch (qualifiedRange range) (qualifyName config name) patterns of
                (Err (UnknownTypeRef _ _)) as errMsg ->

Modified src/Stabel/TypeChecker.elm from [10caad982a] to [ae014cff34].

1596
1597
1598
1599
1600
1601
1602
1603
1604

1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
....
1722
1723
1724
1725
1726
1727
1728






































1729
1730
1731
1732
1733
1734
1735
        ( Just boundA, Just boundB ) ->
            if boundA == boundB then
                ( context, True )

            else
                case ( boundA, boundB ) of
                    ( Type.Union _ leftUnion, Type.Union _ rightUnion ) ->
                        -- TODO: Requires unions to be sorted in same order
                        let

                            lengthTest =
                                List.length leftUnion == List.length rightUnion

                            ( newContext, allMembersTest ) =
                                List.map2 Tuple.pair leftUnion rightUnion
                                    |> List.foldl foldHelper ( context, True )

                            foldHelper ( lType, rType ) ( ctx, currValue ) =
                                if not currValue then
                                    ( ctx, currValue )

                                else
                                    compatibleTypes ctx lType rType
                        in
                        ( newContext
                        , lengthTest && allMembersTest
                        )

                    ( Type.Union _ unionTypes, rhs ) ->
                        -- Cannot normally go from union to concrete type
................................................................................

                    ( Type.Array lt, Type.Array rt ) ->
                        compatibleTypes context lt rt

                    _ ->
                        ( context, False )








































getGenericBinding : Context -> Type -> Maybe Type
getGenericBinding context type_ =
    case type_ of
        Type.Generic genericId ->
            case Dict.get genericId context.boundGenerics of
                Just (Type.Generic nextGenericId) ->







<

>




|
<
<
<
<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1596
1597
1598
1599
1600
1601
1602

1603
1604
1605
1606
1607
1608
1609








1610
1611
1612
1613
1614
1615
1616
....
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
        ( Just boundA, Just boundB ) ->
            if boundA == boundB then
                ( context, True )

            else
                case ( boundA, boundB ) of
                    ( Type.Union _ leftUnion, Type.Union _ rightUnion ) ->

                        let
                            -- TODO: lift this restriction in the future?
                            lengthTest =
                                List.length leftUnion == List.length rightUnion

                            ( newContext, allMembersTest ) =
                                subList leftUnion rightUnion context








                        in
                        ( newContext
                        , lengthTest && allMembersTest
                        )

                    ( Type.Union _ unionTypes, rhs ) ->
                        -- Cannot normally go from union to concrete type
................................................................................

                    ( Type.Array lt, Type.Array rt ) ->
                        compatibleTypes context lt rt

                    _ ->
                        ( context, False )


{-| Is the first list a subset of the second?
-}
subList : List Type -> List Type -> Context -> ( Context, Bool )
subList lhs rhs ctx =
    case lhs of
        [] ->
            ( ctx, True )

        first :: rest ->
            case findMap (compatibleTypes ctx first) Tuple.second rhs of
                Just ( rhsType, ( newContext, _ ) ) ->
                    subList
                        rest
                        (List.filter ((/=) rhsType) rest)
                        newContext

                Nothing ->
                    ( ctx, False )


findMap : (a -> b) -> (b -> Bool) -> List a -> Maybe ( a, b )
findMap mapFn predFn ls =
    case ls of
        [] ->
            Nothing

        first :: rest ->
            let
                mapped =
                    mapFn first
            in
            if predFn mapped then
                Just ( first, mapped )

            else
                findMap mapFn predFn rest


getGenericBinding : Context -> Type -> Maybe Type
getGenericBinding context type_ =
    case type_ of
        Type.Generic genericId ->
            case Dict.get genericId context.boundGenerics of
                Just (Type.Generic nextGenericId) ->

Modified wasm_tests/array.test.js from [ec17f90b23] to [f6c84686e8].

171
172
173
174
175
176
177











































































    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(0);
});



















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(0);
});

test('Pattern match', async () => {
    const wat = await compiler.toWat('main', `
        defunion: Test
        : Int
        : Array Int

        def: main
        type: -- Int
        : { 5 { 1 2 3 } }
          1 array-get
          swap drop
          to-num

        defmulti: to-num
        type: Test -- Int
        : Int
          # do nothing
        : Array
          array-length
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(3);
});

test('Pattern match (reverse case)', async () => {
    const wat = await compiler.toWat('main', `
        defunion: Test
        : Int
        : Array Int

        def: main
        type: -- Int
        : { 5 { 1 2 3 } }
          0 array-get
          swap drop
          to-num

        defmulti: to-num
        type: Test -- Int
        : Int
          # do nothing
        : Array
          array-length
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(5);
});

test('Pattern match (simple)', async () => {
    const wat = await compiler.toWat('main', `
        defunion: Test
        : Int
        : Array Int

        def: main
        type: -- Int
        : { 1 2 3 }
          to-num

        defmulti: to-num
        type: Test -- Int
        : Int
          # do nothing
        : Array
          array-length
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(3);
});