├── .gitignore └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # OS Junk 2 | .DS_Store 3 | Thumbs.db 4 | 5 | # Generated files 6 | dist/ 7 | *.hi 8 | *.o 9 | 10 | # Other build artifacts 11 | Main 12 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 3 | module Main (main) where 4 | 5 | import Control.Arrow (second) 6 | import Control.Monad 7 | import Control.Monad.IO.Class 8 | 9 | import Data.Int 10 | import Data.Word 11 | import Data.List 12 | import Data.IORef 13 | 14 | import qualified Data.Map as M 15 | import qualified Data.Set as S 16 | 17 | import System.IO (fixIO) 18 | 19 | import Foreign.Ptr 20 | 21 | import LLVM.Core 22 | import LLVM.ExecutionEngine 23 | 24 | 25 | -- The language to supercompile 26 | -- ============================ 27 | -- 28 | -- We compile a standard pure, strict, higher-order functional language 29 | -- with algebraic data, case statements, literals and primitive operations. 30 | -- 31 | -- The language has two additional constructors Weaken and Delay that can 32 | -- be used by the producer of the term to mark certainly-unused variables 33 | -- and where compilation should be delayed. 34 | 35 | type Var = String 36 | 37 | type Literal = Int32 38 | 39 | data DataCon = DC { dataConName :: String, dataConTag :: Int32 } 40 | 41 | data PrimOp = Add | Subtract | Multiply 42 | 43 | data Term = Var Var 44 | | Value Val 45 | | App Term Var 46 | | Case Term [(DataCon, [Var], Term)] 47 | | LetRec [(Var, Val)] Term 48 | | Let Var Term Term 49 | | PrimOp PrimOp [Term] 50 | | Weaken Var Term -- Used to "forget" certain variables so we can keep closure size down even in the presence of Delay 51 | | Delay Term -- The compiler is non-strict in the contained Term. Generates code that returns control to the compiler 52 | 53 | data Val = Lambda Var Term 54 | | Data DataCon [Var] 55 | | Literal Literal 56 | 57 | 58 | -- Compilation 59 | -- =========== 60 | 61 | -- | We use this type to represent values in our system that are *either* 62 | -- pointers to heap allocated closures/data *or* immediate Int32 values. 63 | -- 64 | -- LLVM forbids void pointers, so we use the reccomended replacement: 65 | type VoidPtr = Ptr Int8 66 | 67 | -- | All we need to know about the environment in which we compile our code is 68 | -- what the Values of the in-scope variables are. Note that LLVM Values actually 69 | -- correspond to SSA variable names, so this is really which LLVM variable holds 70 | -- the data at the moment 71 | data CompileEnv = CE { 72 | symbolValues :: M.Map Var (Value VoidPtr) 73 | } 74 | 75 | -- | Sometimes we will need to generate a global variable in some module which we 76 | -- refer to later in a different module. However, we wish to create the closure 77 | -- that (when entered) defines the later module *before* we know the address 78 | -- of that global variable. 79 | -- 80 | -- We work around this ordering problem by using a "linker". When generating the first 81 | -- module we will find the address that the JITted global variable lives at. This 82 | -- address will be stored in an IORef after we find out what it is. The address can then 83 | -- be retrieved by the later module (when it actually needs it) by reading the IORef. 84 | type LinkableType = Ptr (Ptr VoidPtr -> IO VoidPtr) -- Keep the system monotyped for now, for simplicity 85 | data CompileState = CS { 86 | linkDemands :: [(Global LinkableType, Ptr LinkableType -> IO ())] 87 | -- ^ The globals we want the address of, and a function that we should call to store each address 88 | } 89 | 90 | 91 | -- | Top level compilation: just invokes compilation for an expression, with additional marshalling from 92 | -- the result type into Int32 (for simplicity, we assume all programs evaluate to Int32). 93 | compileTop :: Term -> CodeGenModule (CompileState, Function (IO Int32)) 94 | compileTop e = tunnelIO (createFunction InternalLinkage) $ 95 | compile (CE { symbolValues = M.empty }) (CS { linkDemands = [] }) e $ 96 | \s value_ptr -> fmap (const s) $ do 97 | x <- ptrtoint value_ptr :: CodeGenFunction Int32 (Value Int32) 98 | ret x :: CodeGenFunction Int32 Terminate 99 | 100 | -- | Compilation of a term. This generates LLVM opcodes and basic blocks within the context of a LLVM 101 | -- Function, so that a particular Value holds the value of the expression being compiled. 102 | compile :: forall r a. 103 | CompileEnv -- ^ The Values for each member of our lexical environment 104 | -> CompileState -- ^ Any pending link information 105 | -> Term -- ^ Term to compile 106 | -> (CompileState -> Value VoidPtr -> CodeGenFunction r a) 107 | -- ^ Continuation: we call this in order to continue compiling the consumer of this value 108 | -> CodeGenFunction r a 109 | compile env s (Var x) k = compileVar env x >>= k s 110 | compile env s (Value v) k = case compileValue (M.keysSet (symbolValues env)) v of 111 | Immediate get_value_ptr -> get_value_ptr >>= k s 112 | HeapAllocated nwords poke -> do 113 | -- We don't bother with garbage collection: just malloc some memory whenever we need it 114 | value_ptr <- arrayMalloc nwords 115 | s <- poke env s value_ptr 116 | bitcast value_ptr >>= k s 117 | compile env s (App e x) k = compile env s e $ \s closure_ptr -> do 118 | arg_ptr <- compileVar env x 119 | 120 | -- Retrieve the function pointer from the first field of the closure: 121 | fun_ptr_ptr <- bitcast closure_ptr :: CodeGenFunction r (Value (Ptr (Ptr (VoidPtr -> VoidPtr -> IO VoidPtr)))) 122 | fun_ptr <- load fun_ptr_ptr 123 | 124 | -- We need to supply the closure itself in the call to the function pointer, so that the 125 | -- function can access its own lexical environment: 126 | call fun_ptr closure_ptr arg_ptr >>= k s 127 | compile env s (Case e alts) k = compile env s e $ \s data_ptr -> do 128 | -- Retrieve the tag from the first field of the data constructor: 129 | tag_ptr <- bitcast data_ptr :: CodeGenFunction r (Value (Ptr Int32)) 130 | tag <- load tag_ptr 131 | 132 | -- Prepare the names of tail blocks, and the code that generates them. 133 | -- We need a tail block for each branch, one for the (hopefully impossible) 134 | -- case where the tag we got didn't match anything, and one block that all the 135 | -- branches of the case will jump to to join up control flow again. The basic 136 | -- blocks look like this (control enters at the top): 137 | -- 138 | -- entry 139 | -- / | \ 140 | -- v v v 141 | -- Tag 0 Tag 1 No match! 142 | -- \ | 143 | -- v v 144 | -- join point 145 | join_block <- newBasicBlock 146 | panic_block <- newBasicBlock 147 | (blocks, define_blocks) <- fmap unzip $ forM alts $ \(dc, xs, e) -> do 148 | alt_block <- newBasicBlock 149 | let -- We're not defining the block *just* yet, since we haven't even emitted the switch: 150 | define_block s = do 151 | defineBasicBlock alt_block 152 | -- When defining a block corresponding to a case branch, we first need to load 153 | -- the fields of the data constructor so we can add them to the lexical env 154 | field_base_ptr <- bitcast data_ptr :: CodeGenFunction r (Value (Ptr VoidPtr)) 155 | env <- forAccumLM_ env (xs `zip` [1..]) $ \env (x, offset) -> do 156 | field_ptr <- getElementPtr field_base_ptr (offset :: Int32, ()) 157 | value_ptr <- load field_ptr 158 | return (env { symbolValues = M.insert x value_ptr (symbolValues env) }) 159 | -- Compile the code from the branch itself: when the branch returns, jump to the join block 160 | (s, result_ptr) <- compile env s e $ \s result_ptr -> br join_block >> return (s, result_ptr) 161 | return (s, (result_ptr, alt_block)) 162 | return ((constOf (dataConTag dc), alt_block), define_block) 163 | 164 | -- Jump into appropriate branch according to the tag we just found: 165 | switch tag panic_block blocks 166 | 167 | -- We've now completed the main block (it ends with that switch). Now define the tail code: 168 | (s, phi_data) <- accumLM s define_blocks -- Blocks for each branch first 169 | defineBasicBlock panic_block -- If no tag matches, do something undefined 170 | unreachable 171 | defineBasicBlock join_block -- When any branch completes, come back here. 172 | phi phi_data >>= k s -- We need a phi node to join the results from each branch. 173 | compile env s (Let x e_bound e_body) k = compile env s e_bound $ \s bound_ptr -> do 174 | compile (env { symbolValues = M.insert x bound_ptr (symbolValues env) }) s e_body k 175 | compile env s (LetRec xvs e_body) k = do 176 | -- Decide how each value will be allocated (immediate or heap allocated) 177 | let avails = S.fromList (map fst xvs) `S.union` M.keysSet (symbolValues env) 178 | (nwords, get_value_ptrs_pokes) = forAccumL 0 xvs $ \nwords_total (x, v) -> case compileValue avails v of 179 | Immediate get_value_ptr -> (nwords_total, (x, \_ -> get_value_ptr >>= bitcast, Nothing)) 180 | HeapAllocated nwords poke -> (nwords_total + nwords, (x, \block_ptr -> getElementPtr block_ptr (nwords_total, ()), Just poke)) 181 | 182 | -- Allocate enough memory for all the values to fit in 183 | block_ptr <- arrayMalloc nwords 184 | -- Now we have the block pointer and the size of each value, we can predict the values each 185 | -- variable actually has before we actually intialize the heap memory they point to (if appropriate). 186 | -- This is essential to tie the knot, because in order to do that initialisation I need to know 187 | -- what the updated lexical environment is. 188 | (value_ptrs, pokes) <- fmap unzip $ forM get_value_ptrs_pokes $ \(x, get_value_ptr, mb_poke) -> do 189 | value_ptr <- get_value_ptr block_ptr 190 | value_ptr' <- bitcast value_ptr :: CodeGenFunction r (Value VoidPtr) 191 | return ((x, value_ptr'), \env s -> maybe (return s) (\poke -> poke env s value_ptr) mb_poke :: CodeGenFunction r CompileState) 192 | 193 | -- Create the extended environment with the new predictions, and actually initialize the values by using that environment 194 | let env' = env { symbolValues = M.fromList value_ptrs `M.union` symbolValues env } 195 | s <- forAccumLM_ s pokes (\s poke -> poke env' s) 196 | 197 | compile env' s e_body k 198 | compile env s (PrimOp pop es) k 199 | = cpsBindN [TH (\s (k :: CompileState -> Value Int32 -> m b) -> compile env s e $ \s value_ptr -> ptrtoint value_ptr >>= k s) 200 | | e <- es] s $ \s arg_ints -> do 201 | res_int <- case (pop, arg_ints) of 202 | (Add, [i1, i2]) -> add i1 i2 203 | (Subtract, [i1, i2]) -> sub i1 i2 204 | (Multiply, [i1, i2]) -> mul i1 i2 205 | _ -> error "Bad primitive operation arity" 206 | inttoptr res_int >>= k s 207 | compile env s (Weaken x e) k = compile (env { symbolValues = M.delete x (symbolValues env) }) s e k 208 | compile env s (Delay e) k = do 209 | -- Create a block of memory we can use to marshal our lexical environment around. 210 | -- We poke our entire lexical environment into this array in an arbitrary order. 211 | -- Every member of the lexical environmont may potentially be required by the code in the Delay. 212 | block_ptr <- arrayAlloca (fromIntegral (M.size (symbolValues env)) :: Word32) 213 | get_block_value_ptrs <- forM ([0..] `zip` M.toList (symbolValues env)) $ \(offset, (x, value_ptr)) -> do 214 | field_ptr <- getElementPtr (block_ptr :: Value (Ptr VoidPtr)) (offset :: Int32, ()) 215 | store value_ptr field_ptr 216 | return $ \block_ptr -> do 217 | field_ptr <- getElementPtr block_ptr (offset, ()) 218 | fmap ((,) x) $ load field_ptr 219 | 220 | -- The code for a Delay transfers control to the function pointer stored in this global. The idea is that: 221 | -- 1) The first time round, this is a pointer to a function that jumps back into Haskell and then reinvokes 222 | -- LLVM to compile the rest of the term. After compilation of the rest of the term (in a new Module), 223 | -- Haskell then rewrites this function pointer to point to the new code, and jumps into that newly-compiled 224 | -- code. 225 | -- 2) On subsequent entries to the Delayed code, we call the function pointer and just jump into the code 226 | -- that was previously compiled by the Haskell trampoline. So we enter Haskell code at most once per Delay, 227 | -- which saves cycles (and is more elegant). 228 | -- 229 | -- I tried to use named globals to link the later module to the earlier one, but LLVM's JIT didn't seem to 230 | -- like it: it couldn't link the name in the later module to the previously-defined one. I have no idea why. 231 | -- The workaround is the linker stuff with IORefs in the CompilerState. 232 | trampoline_global_ptr_ref <- liftIO $ newIORef $ error "compile(Delay): IORef not filled" 233 | 234 | -- Create the Haskell trampoline that will be invoked when we first need to compile this: 235 | reenter_compiler_ptr <- liftIO $ fixIO $ \reenter_compiler_ptr -> wrapDelay $ \block_ptr -> do 236 | -- Build a Module containing: 237 | -- 1. The replacement code, corresponding to compiling the contents of the Delay 238 | -- 2. Fixup code that rewrites the global and then transfers control to the replacement code 239 | fixup_func <- compileAndLink $ do 240 | -- At the point we get in here, the previous round of linking has totally finished, but compiling 241 | -- the body might generate new link demands. Start again with empty linkDemands. 242 | s <- return $ CS { linkDemands = [] } 243 | (s, replacement_func_value) <- tunnelIO1 (createFunction InternalLinkage) $ \(block_ptr :: Value (Ptr VoidPtr)) -> do 244 | -- Create a new lexical environment by pulling values out of the block of memory 245 | -- containing the lexical environment of the caller, then compile the delayed code. 246 | value_ptrs <- mapM ($ block_ptr) get_block_value_ptrs 247 | compile (CE { symbolValues = M.fromList value_ptrs }) s e (\s value_ptr -> fmap (const s) (ret value_ptr)) 248 | 249 | -- This is the fixup function: 250 | trampoline_global_ptr <- liftIO $ readIORef trampoline_global_ptr_ref 251 | fmap ((,) s . generateFunction) $ createFunction InternalLinkage $ \block_ptr -> do 252 | -- Make sure that next time we execute this Delay we jump right to the replacement 253 | trampoline_global <- staticGlobal False trampoline_global_ptr :: CodeGenFunction VoidPtr (Global (Ptr (Ptr VoidPtr -> IO VoidPtr))) 254 | store replacement_func_value trampoline_global 255 | -- Call the replacement code right now to get the work done 256 | call replacement_func_value block_ptr >>= ret 257 | 258 | -- Now that we've compiled the new module, invoke the fixup function: 259 | freeHaskellFunPtr reenter_compiler_ptr -- TODO: I probably shouldn't free this function while it is still running! 260 | fixup_func block_ptr 261 | 262 | -- Create the global variable that will hold the trampoline function pointer 263 | trampoline_global <- liftCodeGenModule $ createGlobal False ExternalLinkage (constOf (castFunPtrToPtr reenter_compiler_ptr)) 264 | s <- return $ s { linkDemands = (trampoline_global, writeIORef trampoline_global_ptr_ref) : linkDemands s } 265 | 266 | -- Generate code that transfers control to the trampoline 267 | trampoline_ptr <- load trampoline_global 268 | call trampoline_ptr block_ptr >>= k s 269 | 270 | foreign import ccall "wrapper" 271 | wrapDelay :: (Ptr VoidPtr -> IO VoidPtr) -> IO (FunPtr (Ptr VoidPtr -> IO VoidPtr)) 272 | 273 | -- | We already have a LLVM Value corresponding to each variable in the lexical environment, so this is easy. 274 | compileVar :: CompileEnv -> Var -> CodeGenFunction r (Value VoidPtr) 275 | compileVar env x = case M.lookup x (symbolValues env) of 276 | Nothing -> error $ "Unbound variable " ++ show x 277 | Just value_ptr -> return value_ptr 278 | 279 | -- | We say that values of the language ar heap allocated if the corresponding (Value VoidPtr) points to the block of heap 280 | -- memory in which they reside. By constrast, if values are immediate the corresponding (Value VoidPtr) isn't a pointer at all, 281 | -- but is rather just a cast version of the actual data. 282 | -- 283 | -- Currently, only Int32s are immediate: functions and data constructors are HeapAllocated. 284 | data ValueBuilder = Immediate (forall r. CodeGenFunction r (Value VoidPtr)) 285 | | HeapAllocated Word32 (forall r. CompileEnv -> CompileState -> Value (Ptr VoidPtr) -> CodeGenFunction r CompileState) 286 | -- ^ Contains the number of words we need to allocate to fit the value, and a function to invoke to fill that memory 287 | 288 | compileValue :: S.Set Var -> Val -> ValueBuilder 289 | compileValue avails v = case v of 290 | -- Do not allocate space: we will pack Int32s into pointers 291 | -- NB: this code assumes Int32s fit into pointers! Probably safe, but... 292 | Literal l -> Immediate $ inttoptr (valueOf l) 293 | -- Allocate space for one pointer per data item, and one pointer for the tag. 294 | -- 295 | -- For example, the list [10] looks like this in memory: 296 | -- 297 | -- /-------\ /-------\ 298 | -- value_ptr--->| 1 | /->| 0 | 299 | -- +-------+ | \-------/ 300 | -- | 10 | | 301 | -- +-------+ | 302 | -- | . |--/ 303 | -- \-------/ 304 | -- 305 | -- (Cons has the tag 1, and Nil uses the tag 0). Addresses increase down the screen, 306 | -- so the leftmost field occupies a lower memory address than the rightmost one. 307 | Data dc xs -> HeapAllocated (1 + genericLength xs) $ \env s data_ptr -> do 308 | -- Poke the tag into the memory allocated for the data constructor 309 | tag_ptr <- bitcast data_ptr :: CodeGenFunction r (Value (Ptr Int32)) 310 | store (valueOf (dataConTag dc)) tag_ptr 311 | 312 | -- Poke the data fields into the allocated memory. Offsets start from 1 because 313 | -- we reserve offset 0 for the tag itself. 314 | forM_ (xs `zip` [1..]) $ \(x, offset) -> do 315 | field_ptr <- getElementPtr data_ptr (offset :: Int32, ()) 316 | value_ptr <- compileVar env x 317 | store value_ptr field_ptr 318 | 319 | return s 320 | -- Allocate space for one pointer per closure variable, and one pointer for the code 321 | -- 322 | -- For example, the closure (let y = 10 in \x -> x + y) looks like this in memory: 323 | -- 324 | -- /-------\ 325 | -- value_ptr--->| . |--->code 326 | -- +-------+ 327 | -- | 10 | 328 | -- \-------/ 329 | -- 330 | -- Addresses increase down the screen, so the code pointer occupies a lower memory 331 | -- address than any of the closed-over variables. 332 | Lambda x e -> HeapAllocated (1 + fromIntegral (S.size avails_used)) $ \env s closure_ptr -> do 333 | -- Figure out at which offset we will store each member of the lexical environment 334 | -- (offsets start at 1 because we reserve offset 0 for the code pointer itself). 335 | -- At the same time we work out what code we need to generate to pull the value out of the closure. 336 | let (closed_value_ptrs, get_closure_value_ptrs) 337 | = unzip $ flip map ([1..] `zip` M.toList (symbolValues env `restrict` avails_used)) $ 338 | \(offset, (x, value_ptr)) -> let get_value_ptr closure_ptr = do 339 | field_ptr <- getElementPtr closure_ptr (offset :: Int32, ()) 340 | load field_ptr 341 | in ((offset, value_ptr), (x, get_value_ptr)) 342 | 343 | -- Define the function corresponding to the lambda body. Each lambda corresponds to a C function with two arguments: 344 | -- a pointer to the closure (which will contain pointers to the lexical environment), and a pointer to the argument 345 | (s, fun_ptr) <- liftCodeGenModule $ tunnelIO2 (createFunction InternalLinkage) $ \closure_ptr arg_ptr -> do 346 | -- Generate the code necessary to pull each member of the lexical environment back out 347 | closure_value_ptrs <- forM get_closure_value_ptrs $ \(x, get_value_ptr) -> fmap ((,) x) $ get_value_ptr closure_ptr 348 | -- Compile the body of the lambda, returning the value that it returns to the caller 349 | compile (env { symbolValues = M.insert x arg_ptr (M.fromList closure_value_ptrs) }) s e $ \s value_ptr -> fmap (const s) (ret value_ptr) 350 | 351 | -- Poke the code into the memory allocated for the closure 352 | fun_ptr_ptr <- bitcast closure_ptr :: CodeGenFunction r (Function (Ptr (Ptr VoidPtr -> VoidPtr -> IO VoidPtr))) 353 | store fun_ptr fun_ptr_ptr 354 | 355 | -- Poke the lexical environment into the closure memory 356 | forM_ closed_value_ptrs $ \(offset, value_ptr) -> do 357 | field_ptr <- getElementPtr closure_ptr (offset, ()) 358 | store value_ptr field_ptr 359 | 360 | return s 361 | where avails_used = S.delete x (termFreeVars avails e) -- We only close over free variables of the lambda body 362 | 363 | 364 | -- This is a proof-of-concept function used to show that (thanks to Weaken) we can still do the 365 | -- useful optimisation of closing over only those things that may be touched in the future. 366 | termFreeVars :: S.Set Var -> Term -> S.Set Var 367 | termFreeVars worst_fvs e = term e 368 | where 369 | term e = case e of 370 | Var x -> S.singleton x 371 | Value v -> value v 372 | App e x -> S.insert x (term e) 373 | Case e alts -> term e `S.union` S.unions [term e S.\\ S.fromList xs | (_, xs, e) <- alts] 374 | LetRec xvs e -> (term e `S.union` S.unions (map value vs)) S.\\ S.fromList xs 375 | where (xs, vs) = unzip xvs 376 | Let x e1 e2 -> term e1 `S.union` S.delete x (term e2) 377 | PrimOp _ es -> S.unions (map term es) 378 | Weaken x e -> S.delete x (term e) 379 | Delay _ -> worst_fvs 380 | -- The interesting case: we have to assume that Delay uses the whole lexical environment. 381 | -- This is why Weaken is important: Weaken trims this set and hence makes it less conservative. 382 | 383 | value v = case v of 384 | Lambda x e -> S.delete x (term e) 385 | Data _ xs -> S.fromList xs 386 | Literal _ -> S.empty 387 | 388 | 389 | -- Just-in-time compilation/linking 390 | -- ================================ 391 | 392 | compileAndLink :: CodeGenModule (CompileState, EngineAccess b) -> IO b 393 | compileAndLink bld = do 394 | m <- newModule 395 | (act, link, mappings) <- defineModule m $ do 396 | (s, act) <- bld 397 | let (linkable_funs, store_linkable_ptr_refs) = unzip (linkDemands s) 398 | get_linkable_fun_ptrs = mapM (fmap castFunPtrToPtr . getPointerToFunction) linkable_funs 399 | link = sequence_ . zipWith ($) store_linkable_ptr_refs 400 | fmap ((,,) (liftM2 (,) get_linkable_fun_ptrs act) link) getGlobalMappings 401 | 402 | --writeBitcodeToFile "/tmp/debug.bc" m 403 | 404 | -- At this point we have a LLVM Module but no actual assembly for it. Generate some. 405 | prov <- createModuleProviderForExistingModule m 406 | (linked_fun_ptrs, res) <- runEngineAccess $ do 407 | addModuleProvider prov 408 | addGlobalMappings mappings 409 | act 410 | 411 | -- At this stage, we have the function pointers we needed to link. Put them into the linker IORefs. 412 | link linked_fun_ptrs 413 | return res 414 | 415 | 416 | -- Test terms and top-level driver 417 | -- =============================== 418 | 419 | trueDataCon, falseDataCon :: DataCon 420 | falseDataCon = DC "False" 0 421 | trueDataCon = DC "True" 1 422 | 423 | nothingDataCon, justDataCon :: DataCon 424 | nothingDataCon = DC "Nothing" 0 425 | justDataCon = DC "Just" 1 426 | 427 | nilDataCon, consDataCon :: DataCon 428 | nilDataCon = DC "Nil" 0 429 | consDataCon = DC "Cons" 1 430 | 431 | test_term :: Term 432 | -- Simple arithmetic: 433 | --test_term = PrimOp Add [Value (Literal 1), Value (Literal 2)] 434 | -- Test that exposed "let" miscompilation: 435 | --test_term = Let "x" (Value (Literal 1)) (Value (Literal 2)) 436 | -- Simple case branches: 437 | --test_term = Case (Value (Data trueDataCon [])) [(trueDataCon, [], Value (Literal 1)), 438 | -- (falseDataCon, [], Value (Literal 2))] 439 | -- Complex case branches: 440 | --test_term = Let "x" (Value (Literal 5)) $ 441 | -- Case (Value (Data justDataCon ["x"])) 442 | -- [(nothingDataCon, [], Value (Literal 1)), 443 | -- (justDataCon, ["y"], Var "y")] 444 | -- Simple function use. Does not need to reference closure: 445 | --test_term = Let "x" (PrimOp Add [Value (Literal 1), Value (Literal 2)]) $ 446 | -- Value (Lambda "y" (PrimOp Multiply [Var "y", Value (Literal 4)])) `App` "x" 447 | -- Complex function use. Needs to reference closure: 448 | --test_term = Let "x" (PrimOp Add [Value (Literal 1), Value (Literal 2)]) $ 449 | -- Let "four" (Value (Literal 4)) $ 450 | -- Value (Lambda "y" (PrimOp Multiply [Var "y", Var "four"])) `App` "x" 451 | -- Letrec: 452 | --test_term = LetRec [("ones", Data consDataCon ["one", "ones"]), 453 | -- ("one", Literal 1), 454 | -- ("zero", Literal 0), 455 | -- ("length", Lambda "xs" (Case (Var "xs") [(nilDataCon, [], Var "zero"), 456 | -- (consDataCon, ["_", "ys"], PrimOp Add [Value (Literal 1), Var "length" `App` "ys"])])), 457 | -- ("list0", Data nilDataCon []), 458 | -- ("list1", Data consDataCon ["one", "list0"]), 459 | -- ("list2", Data consDataCon ["zero", "list1"])] $ 460 | -- Case (Var "ones") [(consDataCon, ["y", "ys"], PrimOp Add [Var "y", Var "length" `App` "list2"])] 461 | -- Trivial delay 462 | --test_term = Delay (Value (Literal 1)) 463 | -- Reentrant delay 464 | --test_term = Let "foo" (Value (Lambda "x" (Delay (PrimOp Add [Var "x", Var "x"])))) $ 465 | -- Let "one" (Value (Literal 1)) $ 466 | -- Let "two" (Value (Literal 2)) $ 467 | -- PrimOp Add [Var "foo" `App` "one", Var "foo" `App` "two"] 468 | -- Nested delay 469 | test_term = Delay (Delay (Value (Literal 1))) 470 | 471 | main :: IO () 472 | main = do 473 | initializeNativeTarget 474 | 475 | -- Compile and link 476 | fun <- compileAndLink $ fmap (second generateFunction) $ compileTop test_term 477 | 478 | -- Run the compiled code 479 | putStrLn "Here we go:" 480 | fun >>= print 481 | 482 | 483 | -- Utility functions 484 | -- ================= 485 | 486 | restrict :: Ord k => M.Map k v -> S.Set k -> M.Map k v 487 | restrict m s = M.filterWithKey (\x _ -> x `S.member` s) m 488 | 489 | -- Impredicative types do not seem to work too well (I can't get the call site to type-check), 490 | -- so I'm working around the issue with this small wrapper: 491 | newtype TypeHack s a m = TH { unTH :: forall r. s -> (s -> a -> m r) -> m r } 492 | 493 | cpsBindN :: [TypeHack s a m] 494 | -> s 495 | -> (s -> [a] -> m r) 496 | -> m r 497 | cpsBindN [] s k = k s [] 498 | cpsBindN (r:rs) s k = unTH r s $ \s x -> cpsBindN rs s $ \s xs -> k s (x:xs) 499 | 500 | tunnelIOCore :: (MonadIO m, MonadIO n) 501 | => ((c -> m ()) -> n b) 502 | -> n (c, b) 503 | tunnelIOCore control = do 504 | -- Urgh, have to resort to tunneling through IORef to get the new State out 505 | s_ref <- liftIO $ newIORef (error "tunnelIO: unfilled IORef") 506 | fun <- control $ liftIO . writeIORef s_ref 507 | s <- liftIO $ readIORef s_ref 508 | return (s, fun) 509 | 510 | tunnelIO :: (MonadIO m, MonadIO n) 511 | => (m () -> n b) 512 | -> m c 513 | -> n (c, b) 514 | tunnelIO control arg = tunnelIOCore (\c2m -> control $ arg >>= c2m) 515 | 516 | tunnelIO1 :: (MonadIO m, MonadIO n) 517 | => ((arg1 -> m ()) -> n b) 518 | -> (arg1 -> m c) 519 | -> n (c, b) 520 | tunnelIO1 control arg = tunnelIOCore (\c2m -> control $ \arg1 -> arg arg1 >>= c2m) 521 | 522 | tunnelIO2 :: (MonadIO m, MonadIO n) 523 | => ((arg1 -> arg2 -> m ()) -> n b) 524 | -> (arg1 -> arg2 -> m c) 525 | -> n (c, b) 526 | tunnelIO2 control arg = tunnelIOCore (\c2m -> control $ \arg1 arg2 -> arg arg1 arg2 >>= c2m) 527 | 528 | accumLM :: (Monad m) => acc -> [acc -> m (acc, y)] -> m (acc, [y]) 529 | accumLM s [] = return (s, []) 530 | accumLM s (f:fs) = do 531 | (s', y) <- f s 532 | (s'',ys) <- accumLM s' fs 533 | return (s'',y:ys) 534 | 535 | forAccumLM_ :: Monad m => acc -> [a] -> (acc -> a -> m acc) -> m acc 536 | forAccumLM_ acc [] _ = return acc 537 | forAccumLM_ acc (x:xs) f = do 538 | acc <- f acc x 539 | forAccumLM_ acc xs f 540 | 541 | forAccumL :: acc -> [a] -> (acc -> a -> (acc, b)) -> (acc, [b]) 542 | forAccumL acc [] _ = (acc, []) 543 | forAccumL acc (x:xs) f = case f acc x of (acc, y) -> case forAccumL acc xs f of (acc, ys) -> (acc, y:ys) 544 | --------------------------------------------------------------------------------