diff options
Diffstat (limited to 'snug-clean/src/Snug/Compile.icl')
| -rw-r--r-- | snug-clean/src/Snug/Compile.icl | 37 |
1 files changed, 34 insertions, 3 deletions
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl index 43f8a37..50119f3 100644 --- a/snug-clean/src/Snug/Compile.icl +++ b/snug-clean/src/Snug/Compile.icl @@ -65,6 +65,9 @@ gatherGlobals ns defs = ] } +lookupConstructor :: !Namespace !ConstructorIdent !Globals -> ?ConstructorDef +lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors + lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions @@ -77,6 +80,7 @@ compileDefinition ns globals (DataDef _ _ constructors) = ] compileDefinition ns globals (FunDef id args ret expr) = [ StartSection "text" + , Global label // TODO: Ideally we would use the following here: //, Align 1 //, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change @@ -87,10 +91,11 @@ 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 (functionLabel ns NodeEntry id) + , Label label : map Instr (compileExpr ns globals locals expr) ] where + label = functionLabel ns NodeEntry id locals = 'Data.Map'.fromList [ (id, Indirect FrontEvalPtr (offset*4)) \\ (id,_) <- args @@ -99,12 +104,15 @@ where compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line] compileConstructor ns _ (ConstructorDef id args) = - [ Align 1 - , Label (constructorLabel ns id) + [ Global label + , Align 1 + , Label label , RawByte (length args) // pointer arity , RawByte 0 // basic value arity , RawByte 0 // number of arguments still to be curried in ] +where + label = constructorLabel ns id compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction] compileExpr ns globals locals expr = simulate $ @@ -127,6 +135,29 @@ simulator ns globals locals (Symbol id) = // TODO include locals buildThunk (functionLabel ns NodeEntry id) 0 _ -> abort "symbol with arity > 0\n" // TODO implement +simulator ns globals locals expr=:(ExpApp _ _) = + case f of + Symbol id -> // TODO include locals + case lookupFunction ns id globals of + ?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up + ?Just info | info.arity == length args -> + mapM_ (simulator ns globals locals) args >>| + buildThunk (functionLabel ns NodeEntry id) info.arity + _ -> abort ("arity mismatch in application\n") // TODO implement + Constructor id -> + case lookupConstructor ns id globals of + ?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up + ?Just (ConstructorDef _ arg_types) | length arg_types == length args -> + mapM_ (simulator ns globals locals) args >>| + buildCons (constructorLabel ns id) (length args) + _ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement + _ -> // TODO + abort "unexpected lhs of function application\n" +where + (f, args) = linearizeApp expr [] + + linearizeApp (ExpApp f x) xs = linearizeApp f [x:xs] + linearizeApp e xs = (e, xs) simulator _ _ _ _ = // TODO pushBasicValue (BVInt 0) >>| buildCons (constructorLabel "" "INT") 1 |