codegen.scm

   1 (load "typecheck.scm")
   2 (load "ast.scm")
   3 (load "platform.scm")
   4
   5 (define target host-os)
   6
   7 (define (emit . s)
   8   (begin
   9     (apply printf s)
  10     (display "\n")))
  11
  12 (define wordsize 8)
  13
  14 (define (type-size data-layouts type)
  15
  16 (define (adt-size adt)
  17     (let ([sizes
  18            (map (lambda (sum)
  19                   (fold-left (lambda (acc x) (+ acc (type-size data-layouts x)))
  20                              wordsize ; one word needed to store tag
  21                              (cdr sum)))
  22                 (cdr adt))])
  23       (apply max sizes)))
  24
  25   (case type
  26     ['Int wordsize]
  27     ['Bool wordsize]
  28     [else
  29      (let ([adt (assoc type data-layouts)])
  30        (if adt
  31            (adt-size adt)
  32            (error #f "unknown size" type)))]))
  33
  34                                         ; returns the size of an expression's result in bytes
  35 (define (expr-size e)
  36   (if (eqv? (ast-type e) 'stack)
  37       (cadr e)
  38       wordsize))
  39
  40 (define (on-stack? expr)
  41   (case (ast-type expr)
  42     ['stack (cadr expr)]
  43     [else #f]))
  44
  45                                         ; an environment consists of adt layouts in scope,
  46                                         ; and any bound variables.
  47                                         ; bound variables are an assoc list with their stack offset
  48 (define make-env list)
  49 (define env-data-layouts car)
  50 (define env-bindings cadr)
  51
  52 (define (codegen-add xs si env)
  53   (define (go ys)
  54     (if (null? ys)
  55         (emit "movq ~a(%rbp), %rax" si)
  56         (begin
  57           (let ((y (car ys)))
  58             (if (integer? y)
  59                 (emit "addq $~a, ~a(%rbp)" y si)
  60                 (begin
  61                   (codegen-expr y (- si wordsize) env)
  62                   (emit "addq %rax, ~a(%rbp)" si))))
  63           (go (cdr ys)))))
  64   (begin
  65                                         ; use si(%rbp) as the accumulator
  66     (emit "movq $0, ~a(%rbp)" si)
  67     (go xs)))
  68
  69 (define (codegen-binop opcode)
  70   (lambda (a b si env)
  71     (codegen-expr b si env)
  72     (emit "movq %rax, ~a(%rbp)" si)
  73     (codegen-expr a (- si wordsize) env)
  74     (emit "~a ~a(%rbp), %rax" opcode si)))
  75
  76 (define codegen-sub (codegen-binop "sub"))
  77
  78 (define codegen-mul (codegen-binop "imul"))
  79
  80 (define (codegen-not x si env)
  81   (codegen-expr x si env)
  82   (emit "notq %rax")
  83   (emit "andq $1, %rax"))
  84
  85 (define (codegen-eq a b si env)
  86   (codegen-expr a si env)
  87   (emit "movq %rax, ~a(%rbp)" si)
  88   (codegen-expr b (- si wordsize) env)
  89   (emit "## ~a = ~b" a b)
  90   (emit "cmpq ~a(%rbp), %rax" si)
  91   (emit "sete %al"))
  92
  93                                         ; 'write file handle addr-string num-bytes
  94
  95 (define (codegen-print x si env)
  96   (codegen-expr x si env) ; x should be a static-string, producing a label
  97
  98                                         ; make a copy of string address since %rax and %rdi are clobbered
  99   (emit "mov %rax, %rbx")
 100
 101                                         ; get the length of the null terminated string
 102   (emit "mov %rax, %rdi")
 103   (emit "xor %al, %al")   ; set %al to 0
 104   (emit "mov $-1, %rcx") ; max search length = max int = -1
 105   (emit "cld")           ; clear direction flag, search up in memory
 106   (emit "repne scasb")   ; scan string, %rcx = -strlen - 1 - 1
 107
 108   (emit "not %rcx")      ; -%rcx = strlen + 1
 109   (emit "dec %rcx")
 110
 111   (emit "movq %rbx, %rsi") ; string addr
 112   (emit "movq %rcx, %rdx") ; num bytes
 113   (emit "movq $1, %rdi")   ; file handle (stdout)
 114   (case target
 115     ('darwin (emit "mov $0x2000004, %rax")) ; syscall 4 (write)
 116     ('linux  (emit "mov $1, %rax"))) ; syscall 1 (write)
 117   (emit "syscall"))
 118
 119 (define (codegen-let bindings body si env)
 120
 121                                         ; is this a closure that captures itself?
 122                                         ; e.g. (let ([x 3] [f (closure lambda0 (f x))]) (f))
 123   (define (self-captive-closure? name expr)
 124     (and (eqv? (ast-type expr) 'closure)
 125          (memv name (caddr expr))))
 126
 127   ;; (define (emit-scc scc env)
 128   ;;   ; acc is a pair of the env and list of touchups
 129   ;;   (define (emit-binding acc binding)
 130   ;;     (let ([binding-name (car binding)]
 131   ;;        [binding-body (cadr binding)]
 132
 133   ;;        [other-bindings (filter
 134   ;;                         (lambda (x) (not (eqv? binding-name x)))
 135   ;;                         scc)]
 136   ;;        [mutually-recursives
 137   ;;         (filter
 138   ;;          (lambda (other-binding)
 139   ;;            (memv other-binding (references binding-body)))
 140   ;;          other-bindings)]
 141
 142   ;;        [new-touchups (append touchups (cdr acc))])
 143
 144   ;;                                    ; TODO: assert that the only mutually recursives are closures
 145   ;;    (for-each
 146   ;;     (lambda (binding)
 147   ;;       (when (not (eqv? (ast-type (cadr binding))
 148
 149   ;;    (emit "asdf")
 150   ;;    (cons new-env new-touchups)
 151   ;;    ))
 152
 153   ;;   (fold-left emit-binding (cons env '()) scc))))
 154                                         ; assoc map of binding name to size
 155   (define stack-sizes
 156     (map (lambda (binding) (cons (car binding) (expr-size (cadr binding))))
 157          bindings))
 158
 159                                         ; assoc map of binding name to offset
 160   (define stack-offsets
 161                                         ; 2  4  2  8  6
 162     (let* ([totals                      ; 2  6  8  16 22
 163             (reverse (fold-left (lambda (acc x)
 164                                   (if (null? acc)
 165                                       (list x)
 166                                       (cons (+ x (car acc)) acc)))
 167                                 '()
 168                                 (map cdr stack-sizes)))]
 169                                         ; 0  2  6  8  16
 170            [relative-offsets (map - totals (map cdr stack-sizes))]
 171            [absolute-offsets (map (lambda (x) (- si x)) relative-offsets)])
 172       (map cons (map car stack-sizes) absolute-offsets)))
 173
 174   (let* (
 175                                         ; the stack index used when codegening binding body and main body
 176                                         ; -> stack ->
 177                                         ; [stack-offsets | inner-si]
 178          [inner-si (- si (fold-left + 0 (map cdr stack-sizes)))]
 179
 180          [get-offset (lambda (n) (cdr (assoc n stack-offsets)))]
 181
 182          [inner-env
 183           (fold-left
 184            (lambda (env comps)
 185              (let* ([scc-binding-offsets
 186                      (fold-left
 187                       (lambda (acc name)
 188                         (cons (cons name (get-offset name))
 189                               acc))
 190                       (env-bindings env)
 191                       comps)]
 192                     [scc-env (make-env (env-data-layouts env) scc-binding-offsets)])
 193                (for-each
 194                 (lambda (name)
 195                   (let* ([expr (cadr (assoc name bindings))]
 196                          [size (expr-size expr)])
 197                     (emit "## generating ~a with scc-env ~a" name scc-env)
 198                     (if (self-captive-closure? name expr)
 199                                         ; if self-captive, insert a flag into the environment to let
 200                                         ; codegen-closure realise this!
 201                         (codegen-expr expr
 202                                       inner-si
 203                                       (make-env
 204                                        (env-data-layouts scc-env)
 205                                        (cons (cons name 'self-captive)
 206                                              (env-bindings scc-env))))
 207                         (codegen-expr expr inner-si scc-env))
 208
 209                     (if (on-stack? expr)
 210                         (begin
 211                           ; copy over whatevers on the stack
 212                           (emit "leaq ~a(%rbp), %rsi" (- inner-si size))
 213                           (emit "leaq ~a(%rbp), %rdi" (- (get-offset name) size))
 214                           (emit "movq $~a, %rcx" (/ size wordsize))
 215                           (emit "rep movsq"))
 216
 217                         (emit "movq %rax, ~a(%rbp)" (get-offset name)))))
 218                 comps)
 219                scc-env))
 220            env
 221            (reverse (sccs (graph bindings))))])
 222
 223     (for-each (lambda (form)
 224                 (codegen-expr form inner-si inner-env))
 225               body)))
 226
 227 (define (codegen-var e si env)
 228   (let* ([stack-size (on-stack? e)]
 229          [name (if (on-stack? e) (caddr e) e)]
 230          [stack-offset (cdr (assoc name (env-bindings env)))])
 231     (when (not stack-offset)
 232       (error #f (format "Variable ~a is not bound" name)))
 233
 234     (if (on-stack? e)
 235         (begin
 236           (emit "leaq ~a(%rbp), %rsi" (- stack-offset stack-size))
 237           (emit "leaq ~a(%rbp), %rdi" (- si stack-size))
 238           (emit "movq $~a, %rcx" (/ stack-size wordsize))
 239           (emit "rep movsq"))
 240         (emit "movq ~a(%rbp), %rax" stack-offset))))
 241
 242 (define cur-lambda 0)
 243 (define (fresh-lambda)
 244   (set! cur-lambda (+ 1 cur-lambda))
 245   (format "_lambda~a" (- cur-lambda 1)))
 246
 247                                         ; a closure on the heap looks like:
 248                                         ; 0    8         16        24
 249                                         ; addr var1....  var2....  var3....
 250
 251 (define (codegen-closure label captured si env)
 252   (let* ((heap-offsets (map (lambda (i) (+ 8 (* 8 i)))
 253                             (range 0 (length captured))))) ; 4, 12, 20, etc.
 254
 255     (emit "## creating closure")
 256
 257     (emit "movq heap_start@GOTPCREL(%rip), %rbx")
 258
 259     (emit "movq (%rbx), %rax")          ; %rax = heap addr of closure
 260
 261
 262                                         ; point heap_start to next space
 263     (emit "addq $~a, (%rbx)" (+ 8 (* 8 (length captured))))
 264
 265     (emit "## storing address to lambda")
 266                                         ; store the address to the lambda code
 267     (emit "movq ~a@GOTPCREL(%rip), %rbx" label)
 268     (emit "movq %rbx, 0(%rax)")
 269
 270     (emit "## storing captives")
 271                                         ; store the captured vars
 272     (for-each
 273      (lambda (var-name heap-offset)
 274        (let ([stack-offset (cdr (assoc var-name (env-bindings env)))])
 275          (emit "### captive ~a" var-name)
 276          (if (eqv? stack-offset 'self-captive)
 277                                         ; captive refers to this closure:
 278                                         ; move heap addr of this closure to stack!
 279              (emit "movq %rax, ~a(%rax)" heap-offset)
 280              (begin
 281                (emit "movq ~a(%rbp), %rbx" stack-offset)
 282                (emit "movq %rbx, ~a(%rax)" heap-offset)))))
 283      captured
 284      heap-offsets)))
 285
 286                                         ; for now we can only call closures
 287 (define (codegen-call f args si env)
 288   (codegen-expr f si env)
 289
 290   (emit "## starting call")
 291
 292   (emit "movq %rax, ~a(%rbp)" si) ; store address of closure first on stack
 293
 294                                         ; codegen the arguments, store them intermediately
 295   (for-each
 296    (lambda (e i)
 297      (begin
 298        (emit "## arg no. ~a" (- i 1))
 299        (codegen-expr e (- si (* wordsize i)) env)
 300                                         ; store intermediate result on stack
 301        (emit "movq %rax, ~a(%rbp)" (- si (* wordsize i)))))
 302
 303    args (range 1 (length args)))
 304
 305                                         ; now that we have everything we need on the stack,
 306                                         ; move them into the param registers
 307
 308   (emit "## moving args into place")
 309   (for-each
 310    (lambda (i) (emit "movq ~a(%rbp), ~a"
 311                      (- si (* wordsize i))
 312                      (param-register i)))
 313    (range 1 (length args)))
 314
 315                                         ; todo: can this be made more efficient
 316   (emit "movq ~a(%rbp), %rax" si)       ; load back pointer to closure
 317
 318   (emit "## moving captives into place")
 319
 320                                         ; move captives into first argument
 321   (emit "movq %rax, %rbx")
 322   (emit "addq $8, %rbx")
 323   (emit "movq %rbx, ~a" (param-register 0))
 324
 325   (emit "## performing call")
 326
 327   (emit "addq $~a, %rsp" si) ; adjust the stack pointer to account all the stuff we put in the env
 328   (emit "callq *(%rax)")                ; call closure function
 329   (emit "subq $~a, %rsp" si))
 330
 331                                         ; LAMBDAS:
 332                                         ; 1st param: pointer to captured args
 333                                         ; 2nd param: 1st arg
 334                                         ; 3rd param: 2nd arg, etc.
 335
 336 (define (codegen-lambda l)
 337   (let* ((label (car l))
 338          (stuff (cdr l))
 339          (captives (car stuff))
 340          (args (cadr stuff))
 341          (body (caddr stuff))
 342                                         ; params = what actually gets passed
 343          (params (append captives args))
 344
 345          (stack-offsets (map (lambda (i)
 346                                (* (- wordsize) (+ 1 i)))
 347                              (range 0 (length params))))
 348
 349          [bindings (map cons params stack-offsets)]
 350          [env (make-env '() bindings)])
 351     (emit "~a:" label)
 352
 353     (display "## lambda captives: ")
 354     (display captives)
 355     (newline)
 356     (display "## lambda args: ")
 357     (display args)
 358     (newline)
 359     (display "## lambda body: ")
 360     (display body)
 361     (newline)
 362
 363     (emit "push %rbp") ; preserve caller's base pointer
 364
 365     (emit "movq %rsp, %rbp") ; set up our own base pointer
 366
 367                                         ; load the captured vars onto the stack
 368     (for-each
 369      (lambda (i)
 370        (begin
 371          (emit "# loading captive ~a" (list-ref captives i))
 372          (emit "movq ~a(~a), %rbx" (* wordsize i) (param-register 0))
 373          (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) (+ 1 i)))))
 374      (range 0 (length captives)))
 375
 376                                         ; load the args onto the stack
 377     (for-each
 378      (lambda (i)
 379        (begin
 380          (emit "movq ~a, %rbx" (param-register (+ 1 i)))
 381          (emit "movq %rbx, ~a(%rbp)"
 382                (* (- wordsize)
 383                   (+ 1 (length captives) i)))))
 384      (range 0 (length args)))
 385
 386     (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
 387
 388     (emit "pop %rbp") ; restore caller's base pointer
 389     (emit "ret")))
 390
 391 (define cur-label 0)
 392 (define (fresh-label)
 393   (set! cur-label (+ 1 cur-label))
 394   (format "label~a" (- cur-label 1)))
 395
 396 (define (codegen-if cond then else si env)
 397   (codegen-expr cond si env)
 398   (emit "cmpq $0, %rax")
 399   (let ((exit-label (fresh-label))
 400         (else-label (fresh-label)))
 401     (emit "je ~a" else-label)
 402     (codegen-expr then si env)
 403     (emit "jmp ~a" exit-label)
 404     (emit "~a:" else-label)
 405     (codegen-expr else si env)
 406     (emit "~a:" exit-label)))
 407
 408 (define (data-tor env e)
 409   (if (not (list? e)) #f
 410       (assoc (car e) (flat-map data-tors (env-data-layouts env)))))
 411
 412                                         ; returns the internal offset in bytes of a product within an ADT
 413                                         ; given the constructor layout
 414                                         ; constructor-layout: (foo (Int Bool))
 415 (define (data-product-offset data-layouts type sum index)
 416   (let* ([products (cdr (assoc sum (cdr (assoc type data-layouts))))]
 417          [to-traverse (list-head products index)])
 418     (fold-left
 419      (lambda (acc t) (+ acc (type-size data-layouts t)))
 420      wordsize ; skip the tag in the first word
 421      to-traverse)))
 422
 423 (define (data-sum-tag data-layouts type sum)
 424
 425   (define (go acc sums)
 426     (when (null? sums) (error #f "data-sum-tag no sum for type" sum type))
 427     (if (eqv? sum (car sums))
 428         acc
 429         (go (+ 1 acc) (cdr sums))))
 430   (let* ([type-sums (cdr (assoc type data-layouts))])
 431     (go 0 (map car type-sums))))
 432
 433 (define (codegen-data-tor e si env)
 434
 435   (define (codegen-destructor tor)
 436     (let* ([res (codegen-expr (cadr e) si env)]
 437            [info (cadr tor)]
 438            [index (caddr info)]
 439            [type (car info)]
 440            [sum (cadr info)])
 441       (when (not (on-stack? (cadr e)))
 442         (error #f "trying to destruct something that isn't a stack expression"))
 443       (emit "# deconstructing")
 444       (emit "movq ~a(%rbp), %rax"
 445             (- si (data-product-offset (env-data-layouts env) type sum index)))))
 446
 447   (define (codegen-constructor tor)
 448     (let* ([info (cadr tor)]
 449            [type (car info)]
 450            [sum (cadr info)]
 451            [constructor (car e)]
 452
 453            [args (cdr e)]
 454
 455            [tag (data-sum-tag (env-data-layouts env)
 456                               type
 457                               sum)]
 458
 459            [insert-product
 460             (lambda (expr i)
 461               (let ([res (codegen-expr expr si env)]
 462                     [stack-offset (- si (data-product-offset (env-data-layouts env)
 463                                                              type sum
 464                                                              i))])
 465                 (if (on-stack? res)
 466                     (error #f "todo: handle stack-exprs in stack exprs")
 467                     (emit "movq %rax, ~a(%rbp)" stack-offset))))])
 468
 469                                         ; emit the tag
 470       (emit "movq $~a, ~a(%rbp)" tag si)
 471
 472       (for-each insert-product args (range 0 (length args)))
 473       (type-size (env-data-layouts env) type)))
 474
 475   (let* ([tor (data-tor env e)]
 476          [constructor (eqv? 'constructor (caddr (cadr tor)))])
 477     (if constructor
 478         (codegen-constructor tor)
 479         (codegen-destructor tor))))
 480
 481 (define (codegen-expr e si env)
 482   (emit "# ~a" e)
 483   (case (ast-type e)
 484     ('closure (codegen-closure (cadr e) (caddr e) si env))
 485     ('app
 486      (case (car e)
 487        ('+ (codegen-add (cdr e) si env))
 488        ('- (codegen-sub (cadr e) (caddr e) si env))
 489        ('* (codegen-mul (cadr e) (caddr e) si env))
 490        ('! (codegen-not (cadr e) si env))
 491        ('= (codegen-eq  (cadr e) (caddr e) si env))
 492        ('bool->int (codegen-expr (cadr e) si env))
 493        ('print (codegen-print (cadr e) si env))
 494        (else
 495         (if (data-tor env e)
 496             (codegen-data-tor e si env)
 497             (codegen-call (car e) (cdr e) si env)))))
 498
 499                                         ; this is a builtin being passed around as a variable
 500                                         ; this should have been converted to a closure!
 501     ('builtin (error #f "passing about a builtin!" e))
 502
 503     ('let (codegen-let (let-bindings e)
 504                        (let-body e)
 505                        si
 506                        env))
 507
 508     ('var (codegen-var e si env))
 509
 510     ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env))
 511
 512     ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
 513     ('int-literal (emit "movq $~a, %rax" e))
 514
 515     ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
 516                           (cadr e)))
 517
 518     ('stack (case (ast-type (caddr e))
 519               ['var (codegen-var e si env)]
 520               [else (codegen-expr (caddr e) si env)]))
 521
 522     (else (error #f "don't know how to codegen this"))))
 523
 524                                         ; takes in a expr annotated with types and returns a type-less AST
 525                                         ; with stack values wrapped
 526 (define (annotate-stack-values data-layouts ann-e)
 527   (define (stack-type? type)
 528     (assoc type data-layouts))
 529   (define (strip e)
 530     (ast-traverse strip (ann-expr e)))
 531   (let* ([e (ann-expr ann-e)]
 532          [type (ann-type ann-e)])
 533     (if (stack-type? type)
 534         `(stack ,(type-size data-layouts type) ,(ast-traverse strip e))
 535         (ast-traverse (lambda (x)
 536                         (annotate-stack-values data-layouts x))
 537                       e))))
 538
 539 (define (free-vars prog)
 540   (define bound '())
 541   (define (collect e)
 542     (case (ast-type e)
 543       ('builtin '()) ; do nothing
 544       ('var (if (memv e bound) '() (list e)))
 545       ('lambda
 546           (begin
 547             (set! bound (append (lambda-args e) bound))
 548             (collect (lambda-body e))))
 549
 550       ('app (flat-map collect e))
 551       ('if (flat-map collect (cdr e)))
 552       ('let
 553           (let ([bind-fvs (flat-map (lambda (a)
 554                                       (begin
 555                                         (set! bound (cons (car a) bound))
 556                                         (collect (cdr a))))
 557                                     (let-bindings e))])
 558             (append bind-fvs (flat-map collect (let-body e)))))
 559       (else '())))
 560   (collect prog))
 561
 562                                         ; ((lambda (x) (+ x y)) 42) => ((closure lambda1 (y)) 42)
 563                                         ;                              [(lambda1 . ((y), (x), (+ x y))]
 564                                         ; for builtins, this generates a closure if it is used
 565                                         ; outside of an immediate app
 566                                         ; but only one closure for each builtin
 567
 568 (define (extract-lambdas program)
 569   (define lambdas '())
 570   (define (add-lambda e)
 571     (let* ((label (fresh-lambda))
 572            (args (lambda-args e))
 573            (captured (free-vars e))
 574            (body (extract (lambda-body e)))
 575            (new-lambda (cons label (list captured args body))))
 576       (set! lambdas (cons new-lambda lambdas))
 577       `(closure ,label ,captured))) ; todo: should we string->symbol?
 578
 579   (define (find-builtin-lambda e)
 580     (let [(l (assq (builtin-name e) lambdas))]
 581       (if l `(closure ,(car l) ,(caadr l)) #f)))
 582
 583   (define (builtin-name e)
 584     (case e
 585       ('+ "_add")
 586       ('- "_sub")
 587       ('* "_mul")
 588       ('! "_not")
 589       ('= "_eq")
 590       ('bool->int "_bool2int")
 591       ('print "_print")
 592       (else (error #f "don't know this builtin"))))
 593   (define (builtin-args e)
 594     (case e
 595       ('+ '(x y))
 596       ('- '(x y))
 597       ('* '(x y))
 598       ('! '(x))
 599       ('= '(x y))
 600       ('bool->int '(x))
 601       ('print '(x))
 602       (else (error #f "don't know this builtin"))))
 603
 604   (define (add-builtin-lambda e)
 605     (let* [(label (builtin-name e))
 606            (captured '())
 607            (args (builtin-args e))
 608            (body `(,e ,@args))
 609            (new-lambda (cons label (list captured args body)))]
 610       (set! lambdas (cons new-lambda lambdas))
 611       `(closure ,label ,captured)))
 612
 613   (define (extract e)
 614     (case (ast-type e)
 615       ('lambda (add-lambda e))
 616       ('let `(let ,(map (lambda (b) `(,(car b) ,@(extract (cdr b)))) (let-bindings e))
 617                ,@(map extract (let-body e))))
 618       ('app (append
 619                                         ; if a builtin is used as a function, don't generate lambda
 620              (if (eqv? 'builtin (ast-type (car e)))
 621                  (list (car e))
 622                  (list (extract (car e))))
 623              (map extract (cdr e))))
 624
 625       ('builtin
 626        (if (find-builtin-lambda e)
 627            (find-builtin-lambda e)
 628            (add-builtin-lambda e)))
 629
 630
 631       (else (ast-traverse extract e))))
 632   (let ((transformed (extract program)))
 633     (cons lambdas transformed)))
 634
 635 (define (extract-strings program)
 636   (let ((cur-string 0)
 637         (strings '())) ; assoc list of labels -> string
 638     (define (fresh-string)
 639       (set! cur-string (+ cur-string 1))
 640       (format "string~a" (- cur-string 1)))
 641     (define (extract e)
 642       (case (ast-type e)
 643         ('string-literal
 644          (let ((label (fresh-string)))
 645            (set! strings (cons (cons label e) strings))
 646            `(static-string ,label)))
 647         (else (ast-traverse extract e))))
 648     (let ((transformed (extract program)))
 649       (cons strings transformed))))
 650
 651 (define (emit-string-data s)
 652   (emit "~a:" (car s))
 653   (emit "\t.string \"~a\"" (cdr s)))
 654
 655                                         ; 24(%rbp) mem arg 1
 656                                         ; 16(%rbp) mem arg 0          prev frame
 657                                         ; -----------------------
 658                                         ;  8(%rbp) return address     cur frame
 659                                         ;  0(%rbp) prev %rbp
 660                                         ; -8(%rbp) do what you want
 661                                         ;  ...     do what you want
 662                                         ;  0(%rsp) do what you want
 663
 664 (define (param-register n)
 665   (case n
 666     (0 "%rdi")
 667     (1 "%rsi")
 668     (2 "%rdx")
 669     (3 "%rcx")
 670     (4 "%r8")
 671     (5 "%r9")
 672     (else (error #f "need to test out the below"))
 673     (else (format "~a(%rsp)" (- n 6)))))
 674
 675 (define (initialize-heap)
 676   (let ((mmap
 677          (case target
 678            ('darwin "0x20000c5")
 679            ('linux "9"))))
 680                                         ; allocate some heap memory
 681     (emit "mov $~a, %rax" mmap) ; mmap
 682     (emit "xor %rdi, %rdi")  ; addr = null
 683     (emit "movq $1024, %rsi")   ; length = 1kb
 684     (emit "movq $0x3, %rdx") ; prot = read | write = 0x2 | 0x1
 685                                         ;    flags = anonymous | private
 686     (case target
 687       ('darwin (emit "movq $0x1002, %r10")) ; anon = 0x1000, priv = 0x02
 688       ('linux (emit "movq $0x22, %r10")))   ; anon = 0x20,   priv = 0x02
 689     (emit "movq $-1, %r8") ; fd = -1
 690     (emit "xor %r9, %r9") ; offset = 0
 691     (emit "syscall")
 692                                         ; %rax now contains pointer to the start of the heap
 693                                         ; keep track of it
 694
 695     (emit "movq heap_start@GOTPCREL(%rip), %rsi")
 696     (emit "movq %rax, (%rsi)")))
 697
 698 (define (codegen program)
 699   (set! cur-label 0)
 700   (set! cur-lambda 0)
 701   (let* ([data-layouts (program-data-layouts program)]
 702
 703          [pattern-matched (expand-pattern-matches program)]
 704          [type-annotated (annotate-types pattern-matched)]
 705          [stack-annotated (annotate-stack-values data-layouts
 706                                                  type-annotated)]
 707
 708          (strings-res (extract-strings stack-annotated))
 709          (strings (car strings-res))
 710          (lambdas-res (extract-lambdas (cdr strings-res)))
 711          (lambdas (car lambdas-res))
 712          (xform-prog (cdr lambdas-res)))
 713
 714     (emit "\t.global _start")
 715     (emit "\t.text")
 716                                         ;    (emit ".p2align 4,,15") is this needed?
 717
 718     (for-each codegen-lambda lambdas)
 719
 720     (emit "_start:")
 721
 722     (initialize-heap)
 723
 724     (emit "movq %rsp, %rbp")            ; set up the base pointer
 725
 726     (codegen-expr xform-prog (- wordsize) (make-env data-layouts '()))
 727
 728                                         ; exit syscall
 729     (emit "mov %rax, %rdi")
 730     (case target
 731       ('darwin (emit "movq $0x2000001, %rax"))
 732       ('linux (emit "mov $60, %rax")))
 733     (emit "syscall")
 734
 735     (emit ".data")
 736
 737     (emit "heap_start:")
 738     (emit "\t.quad 0")
 739
 740     (for-each emit-string-data strings)))
 741
 742 (define (compile-to-binary program output t)
 743   (set! target t)
 744   (when (not (eq? (typecheck program) 'Int)) (error #f "not an Int"))
 745   (let ([tmp-path "/tmp/a.s"])
 746     (when (file-exists? tmp-path) (delete-file tmp-path))
 747     (with-output-to-file tmp-path
 748       (lambda () (codegen program)))
 749
 750     (case target
 751       ('darwin
 752        (system "as /tmp/a.s -o /tmp/a.o")
 753        (system (format "ld /tmp/a.o -e _start -macosx_version_min 10.14 -static -o ~a" output)))
 754       ('linux
 755        (system "as /tmp/a.s -o /tmp/a.o")
 756        (system (format "ld /tmp/a.o -o ~a" output))))))
 757
 758 ; NOTES
 759 ; syscalls in linux and darwin use the following arguments for syscall instruction:
 760 ; %rax = syscall #
 761 ; %rdi = 1st arg
 762 ; %rsi = 2nd arg
 763 ; %rdx = 3rd arg
 764 ; %r10 = 4th arg
 765 ; %r8  = 5th arg
 766 ; %r9  = 6th arg
 767
 768 ; on darwin, unix/posix syscalls are offset by 0x2000000 (syscall classes)
 769 ; https://opensource.apple.com/source/xnu/xnu-2782.20.48/bsd/kern/syscalls.master
 770 ; documentation for most syscalls: /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/usr/include/sys