-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathNano.hs
126 lines (105 loc) · 5.13 KB
/
Nano.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
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
-- | The compiler main module
--
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings, OverloadedLists #-}
module Nano where
--------------------------------------------------------------------------------
import Prelude ( Int , Char , Eq , Show )
import PrimGHC
--------------------------------------------------------------------------------
import Base
import Containers
import Types
import PrimOps
import DataCon
import Syntax
import Parser
import Dependency
import Core
import ScopeCheck
import Inliner
import Closure
import CodeGen
import Eval
{-% include "Base.hs" %-}
{-% include "Containers.hs" %-}
{-% include "Types.hs" %-}
{-% include "PrimOps.hs" %-}
{-% include "DataCon.hs" %-}
{-% include "Syntax.hs" %-}
{-% include "Parser.hs" %-}
{-% include "Dependency.hs" %-}
{-% include "Core.hs" %-}
{-% include "ScopeCheck.hs" %-}
{-% include "Inliner.hs" %-}
{-% include "Closure.hs" %-}
{-% include "CodeGen.hs" %-}
{-% include "Eval.hs" %-}
--------------------------------------------------------------------------------
-- * Compiler entry point
-- | GHC \/ nanohs shared entry point
main = runIO nanoMain
-- | Nano entry point
nanoMain :: IO Unit
nanoMain = iobind getArgs (\args -> case args of { Nil -> printUsage ; Cons cmd args' -> handleCommand cmd args' }) where
{ handleCommand cmd args = case cmd of { Cons dash cmd1 -> ifte (cneq dash '-') printUsage (case cmd1 of { Cons c _ ->
ifte (ceq c 'i') (interpret args) (
ifte (ceq c 'c') (compile False args) (
ifte (ceq c 'o') (compile True args) printUsage)) })}
; interpret args = case args of { Cons input rest -> runInterpreter input ; _ -> printUsage }
; compile flag args = case args of { Cons input rest -> case rest of { Cons output _ -> runCompiler flag input output ; _ -> printUsage } ; _ -> printUsage }}
printUsage :: IO Unit
printUsage = iomapM_ putStrLn
[ "usage:"
, "./nanohs -i <input.hs> # interpret"
, "./nanohs -c <input.hs> <output.c> # compile without optimizations"
, "./nanohs -o <input.hs> <output.c> # compile with optimizations" ]
runCompiler :: Bool -> FilePath -> FilePath -> IO Unit
runCompiler optimize inputFn outputFn = iobind (loadModules Compile inputFn) (\prgdata -> case prgdata of {
PrgData strlits dconTrie coreprg ->
iosequence_
[ putStrLn (append "compiling with optimizations " (ifte optimize "enabled" "disabled"))
, let { lprogram = coreProgramToLifted (ifte optimize (optimizeCorePrg coreprg) coreprg)
; code = runCodeGenM_ (liftedProgramToCode inputFn strlits dconTrie lprogram)
} in writeLines outputFn code
, putStrLn "done." ]})
runInterpreter :: FilePath -> IO Unit
runInterpreter inputFn = iobind (loadModules Interpret inputFn) (\prgdata -> case prgdata of {
PrgData strlits dconTrie coreprg -> case coreprg of { CorePrg blocks mainIdx _main ->
ioseq (putStrLn "interpreting...") (let
{ bigterm = termLevelsToIndices 0 (programToTerm blocks)
; dconNames = mapFromList (map swap (trieToList dconTrie))
; staticEnv = StaticEnv dconNames strlits mainIdx
} in iobind (eval staticEnv NilEnv bigterm) (printValue dconNames) )}})
--------------------------------------------------------------------------------
-- ** Load and parse source files
data ProgramData = PrgData (List String) DataConTable CoreProgram
loadModules :: Mode -> FilePath -> IO ProgramData
loadModules mode inputFn =
iobind (loadAndParse1 Nil inputFn) (\pair -> case pair of { Pair files toplevs -> (let
{ defins0 = catMaybes (map mbDefin toplevs)
; dpair = extractStringConstants defins0 } in case dpair of { Pair strlits defins1 -> let
{ dconTrie = collectDataCons (map located defins1)
; program = reorderProgram defins1
; coreprg = programToCoreProgram mode dconTrie program
} in ioreturn (PrgData strlits dconTrie coreprg) })})
type Files = List FilePath
type Loaded = Pair Files (List TopLevel)
loadAndParseMany :: Files -> List FilePath -> IO Loaded
loadAndParseMany sofar fnames = case fnames of { Nil -> ioreturn (Pair sofar Nil) ; Cons this rest ->
iobind (loadAndParse1 sofar this) (\loaded -> case loaded of { Pair sofar' toplevs1 ->
iobind (loadAndParseMany sofar' rest) (\loaded -> case loaded of { Pair sofar'' toplevs2 ->
ioreturn (Pair sofar'' (append toplevs1 toplevs2)) }) }) }
loadAndParse1 :: Files -> FilePath -> IO Loaded
loadAndParse1 sofar fname = case stringMember fname sofar of
{ True -> ioreturn (Pair sofar Nil)
; False -> ioseq (putStrLn (append "+ " fname)) (iobind (readFile fname) (\text -> let
{ blocks = lexer fname text
; toplevs = map (parseTopLevelBlock fname) blocks
; includes = filterIncludes toplevs
; sofar' = Cons fname sofar
} in iobind (loadAndParseMany sofar' includes) (\loaded -> case loaded of { Pair sofar'' toplevs2 ->
ioreturn (Pair sofar'' (append toplevs toplevs2)) }))) }
--------------------------------------------------------------------------------