diff options
Diffstat (limited to 'snug-clean/src')
-rw-r--r-- | snug-clean/src/Snug/Compile.icl | 38 | ||||
-rw-r--r-- | snug-clean/src/Snug/Compile/Simulate.dcl | 1 | ||||
-rw-r--r-- | snug-clean/src/Snug/Compile/Simulate.icl | 10 |
3 files changed, 48 insertions, 1 deletions
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl index c354950..43f8a37 100644 --- a/snug-clean/src/Snug/Compile.icl +++ b/snug-clean/src/Snug/Compile.icl @@ -34,13 +34,40 @@ compile :: !Namespace ![Definition] -> [Line] compile ns defs = concatMap (compileDefinition ns globals) defs where - globals = + globals = combineGlobals + [ builtin + , gatherGlobals ns defs + ] + + builtin = { constructors = 'Data.Map'.fromList [ ({ns="", id="INT"}, ConstructorDef "INT" []) ] , functions = 'Data.Map'.newMap } +combineGlobals :: ![Globals] -> Globals +combineGlobals sets = + { constructors = 'Data.Map'.unions [g.constructors \\ g <- sets] + , functions = 'Data.Map'.unions [g.functions \\ g <- sets] + } + +gatherGlobals :: !Namespace ![Definition] -> Globals +gatherGlobals ns defs = + { constructors = 'Data.Map'.fromList + [ ({ns=ns, id=id}, cons) + \\ DataDef _ _ conses <- defs + , cons=:(ConstructorDef id _) <- conses + ] + , functions = 'Data.Map'.fromList + [ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))}) + \\ FunDef id args ret _ <- defs + ] + } + +lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo +lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions + compileDefinition :: !Namespace !Globals !Definition -> [Line] compileDefinition _ _ (TypeDef _ _) = [] @@ -91,6 +118,15 @@ simulator _ _ _ (BasicValue bv) = where label (BVInt _) = "INT" label (BVChar _) = "CHAR" +simulator ns globals locals (Symbol id) = // TODO include locals + case lookupFunction ns id globals of + ?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up + ?Just info -> + case info.arity of + 0 -> + buildThunk (functionLabel ns NodeEntry id) 0 + _ -> + abort "symbol with arity > 0\n" // TODO implement simulator _ _ _ _ = // TODO pushBasicValue (BVInt 0) >>| buildCons (constructorLabel "" "INT") 1 diff --git a/snug-clean/src/Snug/Compile/Simulate.dcl b/snug-clean/src/Snug/Compile/Simulate.dcl index a61d631..9b938d5 100644 --- a/snug-clean/src/Snug/Compile/Simulate.dcl +++ b/snug-clean/src/Snug/Compile/Simulate.dcl @@ -19,6 +19,7 @@ from Snug.Syntax import :: BasicValue simulate :: !(Simulator a) -> [Instruction] buildCons :: !Label !Int -> Simulator () +buildThunk :: !Label !Int -> Simulator () pushBasicValue :: !BasicValue -> Simulator () diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl index 620ec3e..b383936 100644 --- a/snug-clean/src/Snug/Compile/Simulate.icl +++ b/snug-clean/src/Snug/Compile/Simulate.icl @@ -87,6 +87,16 @@ buildCons cons nargs = mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>| push addr +buildThunk :: !Label !Int -> Simulator () +buildThunk cons 0 = + write_heap (SVImmediate (Address 0 cons)) >>= \addr -> + modify (\s -> {s & hp_offset=s.hp_offset+4}) >>| // reserve space to overwrite with indir + push addr +buildThunk cons nargs = + write_heap (SVImmediate (Address 0 cons)) >>= \addr -> + mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>| + push addr + pushBasicValue :: !BasicValue -> Simulator () pushBasicValue val = push (SVImmediate (Immediate imm)) where |