diff options
Diffstat (limited to 'snug-clean/src/Snug/Compile.icl')
| -rw-r--r-- | snug-clean/src/Snug/Compile.icl | 40 |
1 files changed, 35 insertions, 5 deletions
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 -> |