aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/docs/backend/rts.md25
-rw-r--r--driver.s51
-rw-r--r--example.snug9
-rw-r--r--snug-clean/src/MIPS/MIPS32.dcl1
-rw-r--r--snug-clean/src/MIPS/MIPS32.icl1
-rw-r--r--snug-clean/src/Snug/Compile.icl40
-rw-r--r--snug-clean/src/Snug/Compile/ABI.dcl1
-rw-r--r--snug-clean/src/Snug/Compile/ABI.icl6
8 files changed, 111 insertions, 23 deletions
diff --git a/doc/docs/backend/rts.md b/doc/docs/backend/rts.md
index d401f3a..36de2ce 100644
--- a/doc/docs/backend/rts.md
+++ b/doc/docs/backend/rts.md
@@ -53,19 +53,18 @@ The arguments of some built-in constructors can be unboxed:
### Hnf descriptors
Descriptors of hnf nodes are located in the data section. They contain
-information about the arity of the node. It also contains the number of
-arguments to be curried in, which is 0 for all data constructors but non-zero
-for the [descriptors of closures](#closure-descriptors). (This means that, in
-principle, data constructor descriptors only need a halfword.)
+information about the arity of the node.
```mipsasm
.align 1
__main_cTuple:
.byte 2 # pointer arity
.byte 0 # basic value arity
- .byte 0 # number of arguments to be curried in
```
+NB: [descriptors of closures](#closure-descriptors) also contain the number of
+arguments to be curried in (minus 1).
+
### Thunk descriptors
Thunk nodes point to the code that can evaluate them. Above this code a
descriptor is used storing information about arity and strictness:
@@ -78,13 +77,13 @@ __main_nappend:
# ...
```
-!!! warning "Implementation may change"
- Strictness will probably be removed in the future, as evaluating arguments
- will be moved out of the driver into generated code (see
- [evaluation](#evaluation)).
+!!! warning "Implementation will change"
+ Strictness will be removed in the future, as evaluating arguments will be
+ moved out of the driver into generated code (see [evaluation](#evaluation)).
- This also makes the implementation of `ap` simpler, as it does not need to
- check strictness of the function it evaluates any more.
+ This makes the implementation of `ap` simpler, as it does not need to check
+ strictness of the function it evaluates any more. Currently `ap` assumes all
+ arguments are strict.
### Closure descriptors
For each thunk with a non-zero number of arguments there is also a closure
@@ -97,12 +96,12 @@ this:
# entry for closure with 0 arguments:
.byte 0 # pointer arity
.byte 0 # basic value arity
- .byte 2 # number of arguments that are still to be curried in
+ .byte 1 # number of arguments that are still to be curried in minus 1
.byte 0 # reserved
# entry for closure with 1 argument:
.byte 1 # pointer arity
.byte 0 # basic value arity
- .byte 1 # number of arguments that are still to be curried in
+ .byte 0 # number of arguments that are still to be curried in minus 1
.byte 0 # reserved
# pointer to corresponding code entry:
__main_uappend:
diff --git a/driver.s b/driver.s
index d717270..bd9d901 100644
--- a/driver.s
+++ b/driver.s
@@ -216,7 +216,7 @@ cycle_error:
#.byte 1 # arity
# TODO: we cannot use the above because SPIM does not accept .byte in text section
.align 2
- .word 0x0001 # strictness, arity
+ .word 0x01000000 # arity, strictness
_nroot:
la $a0,cycle_error
li $v0,4 # print_string
@@ -232,10 +232,57 @@ indir_error:
#.byte 1 # arity
# TODO: we cannot use the above because SPIM does not accept .byte in text section
.align 2
- .word 0x0101 # strictness, arity
+ .word 0x01010000 # arity, strictness
_nindir:
# indirections are handled in eval
la $a0,indir_error
li $v0,4 # print_string
syscall
break 0
+
+ #.align 1
+ #.byte 0x3 # strictness (incorrect; see documentation)
+ #.byte 2 # arity
+ # TODO: we cannot use the above because SPIM does not accept .byte in text section
+ .align 2
+ .word 0x02030000 # arity, strictness
+_nap:
+ # 4($s3) is closure to apply
+ # 8($s3) is argument
+ # NB: assumption: the closure has no basic value arguments
+ lw $t0,4($s3) # t0 -> closure
+ lw $t1,($t0) # t1 -> closure descriptor
+ lbu $t2,($t1) # t2 = closure arity
+ # TODO: check heap space
+ # Create new closure: copy old closure
+ addi $t3,$t1,4 # t3 -> next closure descriptor
+ addi $t5,$gp,0 # t5 -> new closure
+ sw $t3,($gp)
+ addi $t6,$t0,4 # closure argument iterator
+_nap_copy:
+ beq $t2,$0,_nap_copy_done
+ addi $gp,$gp,4 # branch delay slot
+ lw $t4,($t6) # t4 -> closure argument
+ addi $t6,$t6,4
+ sw $t4,($gp)
+ j _nap_copy
+ addi $t2,$t2,-1 # branch delay slot
+_nap_copy_done:
+ # Add new argument
+ lw $t0,8($s3) # t0 -> new argument
+ sw $t0,($gp)
+ addi $gp,$gp,4
+ # Check if the closure is saturated
+ lbu $t2,2($t1) # t2 = number of remaining closure arguments - 1
+ bne $t2,$0,_nap_no_eval
+ # Saturated; create thunk
+ lw $t3,($t3) # function address
+ sw $t3,($t5)
+_nap_no_eval:
+ # Create indirection
+ la $t0,_nindir
+ sw $t0,($s3)
+ sw $t5,4($s3)
+ addi $s3,$t5,0
+ j eval
+ nop
diff --git a/example.snug b/example.snug
index 33d4dab..035934d 100644
--- a/example.snug
+++ b/example.snug
@@ -73,7 +73,10 @@
(Cons _ xs -> length_acc (+ n 1) xs)))
#)
-(fun testb ((x : Int) (y : Char)) : Tuple Int Char :
+
+(fun unary ((x : Int)) : Tuple Int Int :
+ binary x)
+(fun binary ((x : Int) (y : Int)) : Tuple Int Int :
Tuple x y)
-(fun test () : Tuple Int Char :
- testb 37 'a')
+(fun test () : Tuple Int Int :
+ unary 37 42)
diff --git a/snug-clean/src/MIPS/MIPS32.dcl b/snug-clean/src/MIPS/MIPS32.dcl
index 6e5ff44..83f15cb 100644
--- a/snug-clean/src/MIPS/MIPS32.dcl
+++ b/snug-clean/src/MIPS/MIPS32.dcl
@@ -10,6 +10,7 @@ from StdOverloaded import class toString
| Instr !Instruction
| RawByte !Int
| RawWord !Int
+ | RawWordLabel !Label
| RawAscii !String
instance toString Line
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
index ca5cbee..655219d 100644
--- a/snug-clean/src/MIPS/MIPS32.icl
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -13,6 +13,7 @@ where
toString (Instr i) = "\t" +++ toString i
toString (RawByte i) = "\t.byte\t" +++ toString i
toString (RawWord i) = "\t.word\t" +++ toString i
+ toString (RawWordLabel l) = "\t.word\t" +++ l
toString (RawAscii s) = concat3 "\t.ascii\t\"" s "\"" // TODO: escaping
instance toString Instruction
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 8c23134..dcbc5ad 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -89,8 +89,27 @@ compileDefinition ns globals (DataDef _ _ constructors) =
flatten <$> mapM (compileConstructor ns globals) constructors
compileDefinition ns globals (FunDef id args ret expr) =
(++)
+ (if (isEmpty args) [] (
+ [ StartSection "data"
+ , Align 2
+ ] ++ flatten
+ [[ Label (closure_label i)
+ // TODO: Ideally we would use the following here:
+ //, RawByte i // pointer arity
+ //, RawByte 0 // basic value arity
+ //, RawByte (length args-i-1) // number of arguments that still have to be curried in minus 1
+ //, RawByte 0 // reserved
+ // But since SPIM does not allow .byte in the text section, we use:
+ , RawWord
+ (i bitor // pointer arity
+ ((length args-i-1) << 16)) // number of arguments that still have to be curried in minus 1
+ ] \\ i <- [0..length args-1]
+ ] ++
+ [ RawWordLabel n_label
+ ])) <$>
+ (++)
[ StartSection "text"
- , Global label
+ , Global n_label
// TODO: Ideally we would use the following here:
//, Align 1
//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
@@ -101,11 +120,12 @@ compileDefinition ns globals (FunDef id args ret expr) =
(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
(length args << 8)) // arity
// instead... (end modification)
- , Label label
+ , Label n_label
] <$>
map Instr <$> compileExpr ns globals locals expr
where
- label = functionLabel ns NodeEntry id
+ closure_label i = closureLabel ns id i
+ n_label = functionLabel ns NodeEntry id
locals = 'Data.Map'.fromList
[ (id, FrontPtrArg offset)
\\ (id,_) <- args
@@ -119,7 +139,7 @@ compileConstructor ns _ (ConstructorDef id args) = pure
, Label label
, RawByte (length args) // pointer arity
, RawByte 0 // basic value arity
- , RawByte 0 // number of arguments still to be curried in
+ //, RawByte -1 // number of arguments still to be curried in (unused for constructors)
]
where
label = constructorLabel ns id
@@ -157,7 +177,17 @@ simulator ns globals locals expr=:(ExpApp _ _) =
| info.arity == length args ->
mapM_ (simulator ns globals locals) (reverse args) >>|
buildThunk (functionLabel ns NodeEntry id) info.arity
- | otherwise -> fail "arity mismatch in application" // TODO implement
+ | info.arity > length args ->
+ mapM_ (simulator ns globals locals) (reverse args) >>|
+ buildCons (closureLabel ns id (length args)) (length args)
+ | info.arity < length args ->
+ let
+ (closure_args,extra_args) = splitAt info.arity args
+ closure = foldl ExpApp f closure_args
+ in
+ mapM_ (simulator ns globals locals) extra_args >>|
+ simulator ns globals locals closure >>|
+ mapM_ (\_ -> buildThunk (functionLabel "" NodeEntry "ap") 2) extra_args
Constructor id ->
liftT (lookupConstructor ns id globals) >>= \(ConstructorDef _ arg_types)
| length arg_types == length args ->
diff --git a/snug-clean/src/Snug/Compile/ABI.dcl b/snug-clean/src/Snug/Compile/ABI.dcl
index 6de2953..c7fe7ad 100644
--- a/snug-clean/src/Snug/Compile/ABI.dcl
+++ b/snug-clean/src/Snug/Compile/ABI.dcl
@@ -21,3 +21,4 @@ TempImm :== T 0
constructorLabel :: !Namespace !ConstructorIdent -> Label
functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
+closureLabel :: !Namespace !SymbolIdent !Int -> Label
diff --git a/snug-clean/src/Snug/Compile/ABI.icl b/snug-clean/src/Snug/Compile/ABI.icl
index 66a8d5c..225f09c 100644
--- a/snug-clean/src/Snug/Compile/ABI.icl
+++ b/snug-clean/src/Snug/Compile/ABI.icl
@@ -20,11 +20,15 @@ where
e = case entry_point of
NodeEntry -> 'n'
+closureLabel :: !Namespace !SymbolIdent !Int -> Label
+closureLabel ns id nargs = constructorLabel ns (concat3 id "@" (toString nargs))
+
escapeLabel :: !String -> String
escapeLabel s = {#c \\ c <- escape [c \\ c <-: s]}
where
escape [] = []
escape [c:cs] | isAlphanum c = [c:escape cs]
+ // Symbols allowed in snug but not in symbol names:
escape ['_':cs] = ['__':escape cs]
escape ['`':cs] = ['_B':escape cs]
escape [':':cs] = ['_C':escape cs]
@@ -36,3 +40,5 @@ where
escape ['+':cs] = ['_P':escape cs]
escape ['\'':cs] = ['_Q':escape cs]
escape ['~':cs] = ['_T':escape cs]
+ // Symbols not allowed in snug but used internally:
+ escape ['@':cs] = ['_c':escape cs] // see closureLabel
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 20:59:20 +0000